From 93a8ed7565cb767a181a9f5c2c3486dddb8b1c71 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 30 Jul 2013 16:55:38 +0100 Subject: [PATCH 001/260] CA-112572: networkd: protect IP watcher thread with an exception handler Signed-off-by: Rob Hoes --- networkd/network_monitor_thread.ml | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index 1037a16ba..640d5cf3e 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -259,7 +259,6 @@ let ip_watcher () = ); Unix.close writeme; let in_channel = Unix.in_channel_of_descr readme in - debug "Started IP watcher thread"; let rec loop () = let line = input_line in_channel in (* Do not send events for link-local IPv6 addresses, and removed IPs *) @@ -272,7 +271,13 @@ let ip_watcher () = end; loop () in - loop () + while true do + try + info "(Re)started IP watcher thread"; + loop () + with e -> + warn "Error in IP watcher: %s\n%s" (Printexc.to_string e) (Printexc.get_backtrace ()) + done let start () = let dbg = "monitor_thread" in From 15b602b0b786a12b153d0a6eb85d43ff270a4fc5 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Fri, 23 Aug 2013 13:19:47 +0100 Subject: [PATCH 002/260] CA-82314: networkd: introduce Linklocal6 IPv6 address mode This commit redefines the IPv6 address mode "None6" to mean "no IPv6 address at all, not even a link local one", and introduces the new mode Linklocal6, which means "only IPv6 address, except a link local one". Previously, it was not possible to get networkd to remove the link-local IPv6 address from an interface. When a link local IPv6 address is requested, it is derived from the interface's MAC address as commonly done. Signed-off-by: Rob Hoes Imported-by: Jon Ludlam --- lib/network_utils.ml | 49 ++++++++++++++++++++++++++++++++++---- networkd/network_server.ml | 10 ++++++++ networkd_db/networkd_db.ml | 2 +- 3 files changed, 55 insertions(+), 6 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index f4387bb4f..d61addc2b 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -234,6 +234,42 @@ info "Found at [ %s ]" (String.concat ", " (List.map string_of_int indices)); Some (ip, prefixlen) with Not_found -> None + (* see http://en.wikipedia.org/wiki/IPv6_address#Modified_EUI-64 *) + let get_ipv6_interface_id dev = + let mac = get_mac dev in + let bytes = List.map (fun byte -> int_of_string ("0x" ^ byte)) (String.split ':' mac) in + let rec modified_bytes ac i = function + | [] -> + ac + | head :: tail -> + if i = 0 then + let head' = head lxor 2 in + modified_bytes (head' :: ac) 1 tail + else if i = 2 then + modified_bytes (254 :: 255 :: head :: ac) 3 tail + else + modified_bytes (head :: ac) (i + 1) tail + in + let bytes' = List.rev (modified_bytes [] 0 bytes) in + [0; 0; 0; 0; 0; 0; 0; 0] @ bytes' + + let get_ipv6_link_local_addr dev = + let id = get_ipv6_interface_id dev in + let link_local = 0xfe :: 0x80 :: (List.tl (List.tl id)) in + let rec to_string ac i = function + | [] -> ac + | hd :: tl -> + let separator = + if i = 0 || i mod 2 = 1 then + "" + else + ":" + in + let ac' = ac ^ separator ^ Printf.sprintf "%02x" hd in + to_string ac' (i + 1) tl + in + to_string "" 0 link_local ^ "/64" + let get_ipv4 dev = let addrs = addr dev "inet" in List.filter_map split_addr addrs @@ -254,13 +290,16 @@ info "Found at [ %s ]" (String.concat ", " (List.map string_of_int indices)); ignore (call ~log:true (["addr"; "add"; addr; "dev"; dev] @ broadcast)) with _ -> () + let set_ipv6_link_local_addr dev = + let addr = get_ipv6_link_local_addr dev in + try + ignore (call ~log:true ["addr"; "add"; addr; "dev"; dev; "scope"; "link"]) + with _ -> () + let flush_ip_addr ?(ipv6=false) dev = try - if ipv6 then begin - ignore (call ~log:true ["-6"; "addr"; "flush"; "dev"; dev; "scope"; "global"]); - ignore (call ~log:true ["-6"; "addr"; "flush"; "dev"; dev; "scope"; "site"]) - end else - ignore (call ~log:true ["-4"; "addr"; "flush"; "dev"; dev]) + let mode = if ipv6 then "-6" else "-4" in + ignore (call ~log:true [mode; "addr"; "flush"; "dev"; dev]) with _ -> () let route_show ?(version=V46) dev = diff --git a/networkd/network_server.ml b/networkd/network_server.ml index c5b3f0bb8..258d8aaa3 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -194,20 +194,30 @@ module Interface = struct Sysctl.set_ipv6_autoconf name false; Ip.flush_ip_addr ~ipv6:true name end + | Linklocal6 -> + if List.mem name (Sysfs.list ()) then begin + Dhcp6c.stop name; + Sysctl.set_ipv6_autoconf name false; + Ip.flush_ip_addr ~ipv6:true name; + Ip.set_ipv6_link_local_addr name + end | DHCP6 -> Dhcp6c.stop name; Sysctl.set_ipv6_autoconf name false; Ip.flush_ip_addr ~ipv6:true name; + Ip.set_ipv6_link_local_addr name; Dhcp6c.start name | Autoconf6 -> Dhcp6c.stop name; Ip.flush_ip_addr ~ipv6:true name; + Ip.set_ipv6_link_local_addr name; Sysctl.set_ipv6_autoconf name true; (* Cannot link set down/up due to CA-89882 - IPv4 default route cleared *) | Static6 addrs -> Dhcp6c.stop name; Sysctl.set_ipv6_autoconf name false; Ip.flush_ip_addr ~ipv6:true name; + Ip.set_ipv6_link_local_addr name; List.iter (Ip.set_ip_addr name) addrs ) () diff --git a/networkd_db/networkd_db.ml b/networkd_db/networkd_db.ml index 9425ca151..f96fcb76d 100644 --- a/networkd_db/networkd_db.ml +++ b/networkd_db/networkd_db.ml @@ -88,7 +88,7 @@ let _ = | Some addr -> ["gatewayv6", Unix.string_of_inet_addr addr] in mode @ addrs @ gateway - | None6 -> [] + | None6 | Linklocal6 -> [] in let data = datav4 @ datav6 in List.iter (fun (k, v) -> Printf.printf "%s=%s\n" k v) data From 0148e1d5b1d636d5e214f8de7f838c9268b5a0a2 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Tue, 24 Sep 2013 18:25:03 +0100 Subject: [PATCH 003/260] Use syslog from xcp-idl Signed-off-by: Jon Ludlam --- lib/network_config.ml | 2 +- lib/network_utils.ml | 2 +- networkd/network_monitor_thread.ml | 2 +- networkd/network_server.ml | 2 +- networkd/networkd.ml | 4 ++-- xcp-networkd.obuild | 4 ++-- 6 files changed, 8 insertions(+), 8 deletions(-) diff --git a/lib/network_config.ml b/lib/network_config.ml index c066694e4..fe0d969e8 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -17,7 +17,7 @@ open Network_interface open Fun open Stringext -module D = Debug.Debugger(struct let name = "network_config" end) +module D = Debug.Make(struct let name = "network_config" end) open D exception Read_error diff --git a/lib/network_utils.ml b/lib/network_utils.ml index d61addc2b..0096fc768 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -17,7 +17,7 @@ open Stringext open Fun open Network_interface -module D = Debug.Debugger(struct let name = "network_utils" end) +module D = Debug.Make(struct let name = "network_utils" end) open D let iproute2 = "/sbin/ip" diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index 640d5cf3e..1bf727454 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -19,7 +19,7 @@ open Stringext open Listext open Threadext -module D = Debug.Debugger(struct let name = "network_monitor_thread" end) +module D = Debug.Make(struct let name = "network_monitor_thread" end) open D (** Table for bonds status. *) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 258d8aaa3..5cdc8a4cf 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -19,7 +19,7 @@ open Fun open Stringext open Listext -module D = Debug.Debugger(struct let name = "network_server" end) +module D = Debug.Make(struct let name = "network_server" end) open D type context = unit diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 38ed7f949..f2d9762b7 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -16,7 +16,7 @@ open Pervasiveext open Fun open Network_utils -module D = Debug.Debugger(struct let name = "networkd" end) +module D = Debug.Make(struct let name = "networkd" end) open D module Server = Network_interface.Server(Network_server) @@ -65,7 +65,7 @@ let _ = Xcp_service.maybe_daemonize (); - Debug.set_facility Syslog_transitional.Local5; + Debug.set_facility Syslog.Local5; (* We should make the following configurable *) Debug.disable "http"; diff --git a/xcp-networkd.obuild b/xcp-networkd.obuild index 19d7e155d..598b5dea4 100644 --- a/xcp-networkd.obuild +++ b/xcp-networkd.obuild @@ -6,14 +6,14 @@ obuild-ver: 1 library network-libs src-dir: lib modules: network_config, network_utils - build-deps: forkexec, stdext, threads, rpclib, log, stdext, xcp-inventory, xcp.network + build-deps: forkexec, stdext, threads, rpclib, stdext, xcp-inventory, xcp.network cdir: lib c-sources: link_stubs.c executable xcp-networkd main: networkd.ml src-dir: networkd - build-deps: threads, rpclib, rpclib.unix, forkexec, stdext, log, http-svr, xcp-inventory, network-libs, xen-api-client, xcp, xcp.network + build-deps: threads, rpclib, rpclib.unix, forkexec, stdext, http-svr, xcp-inventory, network-libs, xen-api-client, xcp, xcp.network pp: camlp4o executable networkd_db From 8b54e9c825018c39c277d443468f1d0241b88fe2 Mon Sep 17 00:00:00 2001 From: David Scott Date: Wed, 25 Sep 2013 15:14:13 +0000 Subject: [PATCH 004/260] Release 0.9.3 Signed-off-by: David Scott --- ChangeLog | 8 ++++++++ VERSION | 2 +- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index fc4b07012..d066396a8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +0.9.3 (24-Sep-2013): +* Allow the Bond.create to carry on even if the MTU size is invalid +* network monitor: better represent duplex mode for NIC bonds +* Use "ip link" to find the MAC address and MTU of a NIC +* Batch IP monitor changes for 1 second +* Signal xapi when an IP address is removed +* networkd: introduce Linklocal6 IPv6 address mode + 0.9.1 (7-Jun-2013): * monitor IPv4 address changes as well as IPv6 diff --git a/VERSION b/VERSION index 1892b9267..965065db5 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -1.3.2 +0.9.3 From 5b97592aaff07760693a416d100c253ebe456987 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Thu, 26 Sep 2013 14:11:25 +0100 Subject: [PATCH 005/260] CA-105789: Ensure the bridge has the correct MAC on first boot Signed-off-by: Jon Ludlam --- lib/network_config.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lib/network_config.ml b/lib/network_config.ml index fe0d969e8..879e91664 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -34,6 +34,7 @@ let read_management_conf () = let device = List.assoc "LABEL" args in Inventory.reread_inventory (); let bridge_name = Inventory.lookup Inventory._management_interface in + let mac = Network_utils.Ip.get_mac bridge_name in debug "Management bridge in inventory file: %s" bridge_name; let ipv4_conf, ipv4_gateway, dns = match List.assoc "MODE" args with @@ -63,6 +64,7 @@ let read_management_conf () = let phy_interface = {default_interface with persistent_i = true} in let bridge_interface = {default_interface with ipv4_conf; ipv4_gateway; persistent_i = true} in let bridge = {default_bridge with + bridge_mac = Some mac; ports = [device, {default_port with interfaces = [device]}]; persistent_b = true } in From e23a6c1c71bf0a1c994ff546db3db6dc47640dc7 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Thu, 10 Oct 2013 14:29:25 +0100 Subject: [PATCH 006/260] Use the interface name, not the bridge name when looking up MAC This is for firstboot and for when xe-reset-networking has been executed. Acked-by: Rob Hoes Signed-off-by: Jon Ludlam --- lib/network_config.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/network_config.ml b/lib/network_config.ml index 879e91664..186a21127 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -34,8 +34,8 @@ let read_management_conf () = let device = List.assoc "LABEL" args in Inventory.reread_inventory (); let bridge_name = Inventory.lookup Inventory._management_interface in - let mac = Network_utils.Ip.get_mac bridge_name in debug "Management bridge in inventory file: %s" bridge_name; + let mac = Network_utils.Ip.get_mac device in let ipv4_conf, ipv4_gateway, dns = match List.assoc "MODE" args with | "static" -> From f0d3260fc1b0ee6a6782c89a914e717d4e038b40 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 15 Oct 2013 11:36:25 +0100 Subject: [PATCH 007/260] CA-116420: when creating linux bond, add MAC address after adding bond slaves This is needed under kernel 3.x, because the kernel now changes the bond MAC to the MAC of the first slave that is added, which is not always what we want. Signed-off-by: Rob Hoes --- networkd/network_server.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 258d8aaa3..740c880f8 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -632,12 +632,12 @@ module Bridge = struct end else begin if not (List.mem name (Sysfs.bridge_to_interfaces bridge)) then begin Linux_bonding.add_bond_master name; + List.iter (fun name -> Interface.bring_down () dbg ~name) interfaces; + List.iter (Linux_bonding.add_bond_slave name) interfaces; begin match bond_mac with | Some mac -> Ip.set_mac name mac | None -> warn "No MAC address specified for the bond" end; - List.iter (fun name -> Interface.bring_down () dbg ~name) interfaces; - List.iter (Linux_bonding.add_bond_slave name) interfaces; let bond_properties = if List.mem_assoc "mode" bond_properties && List.assoc "mode" bond_properties = "lacp" then List.replace_assoc "mode" "802.3ad" bond_properties From 0726ee01d071daa0ed8f1011e8bd5e6b05fee47b Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 15 Oct 2013 11:36:25 +0100 Subject: [PATCH 008/260] CA-116420: when creating linux bond, add MAC address after adding bond slaves This is needed under kernel 3.x, because the kernel now changes the bond MAC to the MAC of the first slave that is added, which is not always what we want. Signed-off-by: Rob Hoes --- networkd/network_server.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 5cdc8a4cf..d0c2b1401 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -632,12 +632,12 @@ module Bridge = struct end else begin if not (List.mem name (Sysfs.bridge_to_interfaces bridge)) then begin Linux_bonding.add_bond_master name; + List.iter (fun name -> Interface.bring_down () dbg ~name) interfaces; + List.iter (Linux_bonding.add_bond_slave name) interfaces; begin match bond_mac with | Some mac -> Ip.set_mac name mac | None -> warn "No MAC address specified for the bond" end; - List.iter (fun name -> Interface.bring_down () dbg ~name) interfaces; - List.iter (Linux_bonding.add_bond_slave name) interfaces; let bond_properties = if List.mem_assoc "mode" bond_properties && List.assoc "mode" bond_properties = "lacp" then List.replace_assoc "mode" "802.3ad" bond_properties From d45958eb6456f808a372b1891c1e8f7368c68da4 Mon Sep 17 00:00:00 2001 From: Mike McClurg Date: Wed, 23 Oct 2013 15:54:07 +0000 Subject: [PATCH 009/260] Add .merlin file Signed-off-by: Mike McClurg --- .merlin | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) create mode 100644 .merlin diff --git a/.merlin b/.merlin new file mode 100644 index 000000000..4b30ddf1f --- /dev/null +++ b/.merlin @@ -0,0 +1,19 @@ +S lib +S networkd +S networkd_db +S test +B dist/build/lib-network-libs/ +B dist/build/xcp-networkd +B dist/build/networkd_db +B dist/build/network_test +PKG forkexec +PKG rpclib +PKG stdext +PKG stdext +PKG threads +PKG unix +PKG xcp +PKG xcp-inventory +PKG xcp.network +PKG xcp.network +PKG xen-api-client From 11862935c6e053a48d0338a4dbd3a42d2be30c21 Mon Sep 17 00:00:00 2001 From: John Else Date: Fri, 25 Oct 2013 14:47:42 +0100 Subject: [PATCH 010/260] Remove http-svr dependency networkd has been using cohttp via xcp-idl since commit e6b2f0774b71683b4a970ce64c96e6d31f11e488 Signed-off-by: John Else --- xcp-networkd.obuild | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/xcp-networkd.obuild b/xcp-networkd.obuild index 598b5dea4..1bc389914 100644 --- a/xcp-networkd.obuild +++ b/xcp-networkd.obuild @@ -13,7 +13,7 @@ library network-libs executable xcp-networkd main: networkd.ml src-dir: networkd - build-deps: threads, rpclib, rpclib.unix, forkexec, stdext, http-svr, xcp-inventory, network-libs, xen-api-client, xcp, xcp.network + build-deps: threads, rpclib, rpclib.unix, forkexec, stdext, xcp-inventory, network-libs, xen-api-client, xcp, xcp.network pp: camlp4o executable networkd_db From faf4959e2e074a4b39d3c10645c0bc5ccdf5d73f Mon Sep 17 00:00:00 2001 From: Ravi Kondamuru Date: Tue, 29 Oct 2013 16:45:44 +0000 Subject: [PATCH 011/260] CA-99828 Add a new bond option: lacp-fallback-ab lacp-fallback-ab allows lacp bond to fallback to active-backup when there is no lacp partner. Signed-off-by: Ravi Kondamuru --- lib/network_utils.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 0096fc768..7fa8bdc1e 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -751,7 +751,7 @@ module Ovs = struct let make_bond_properties name properties = let known_props = ["mode"; "hashing-algorithm"; "updelay"; "downdelay"; "miimon"; "use_carrier"; "rebalance-interval"; - "lacp-time"; "lacp-aggregation-key"] in + "lacp-time"; "lacp-aggregation-key"; "lacp-fallback-ab"] in let mode_args = let mode = if List.mem_assoc "mode" properties then List.assoc "mode" properties else "balance-slb" in @@ -795,7 +795,8 @@ module Ovs = struct "use_carrier", "other-config:bond-detect-mode"; "rebalance-interval", "other-config:bond-rebalance-interval";]) and extra_args = List.flatten (List.map get_prop - ["lacp-time", "other-config:lacp-time";]) + ["lacp-time", "other-config:lacp-time"; + "lacp-fallback-ab", "other-config:lacp-fallback-ab";]) and per_iface_args = List.flatten (List.map get_prop ["lacp-aggregation-key", "other-config:lacp-aggregation-key"; "lacp-actor-key", "other-config:lacp-actor-key";]) From 846e923087eba3853a6eb458e49fd1c5bd4c903c Mon Sep 17 00:00:00 2001 From: Andrew Cooper Date: Mon, 18 Nov 2013 14:26:58 +0000 Subject: [PATCH 012/260] CA-121503 - Make use of rc and stderr when appropriate. Signed-off-by: Andrew Cooper --- networkd_db/networkd_db.ml | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/networkd_db/networkd_db.ml b/networkd_db/networkd_db.ml index f96fcb76d..389937ad7 100644 --- a/networkd_db/networkd_db.ml +++ b/networkd_db/networkd_db.ml @@ -20,6 +20,7 @@ let name = "networkd_db" let _ = let bridge = ref "" in let iface = ref "" in + let rc = ref 0 in Arg.parse (Arg.align [ "-bridge", Arg.Set_string bridge, "Bridge name"; "-iface", Arg.Set_string iface, "Interface name"; @@ -35,7 +36,8 @@ let _ = let ifaces = List.flatten (List.map (fun (_, port) -> port.interfaces) bridge_config.ports) in Printf.printf "interfaces=%s\n" (String.concat "," ifaces) end else - print_endline ("Could not find bridge " ^ !bridge); + rc := 1; + Printf.fprintf stderr "Could not find bridge %s\n" !bridge; if !iface <> "" then if List.mem_assoc !iface config.interface_config then begin @@ -93,7 +95,8 @@ let _ = let data = datav4 @ datav6 in List.iter (fun (k, v) -> Printf.printf "%s=%s\n" k v) data end else - print_endline ("Could not find interface " ^ !iface); + rc := 1; + Printf.fprintf stderr "Could not find interface %s\n" !iface; with Network_config.Read_error -> - print_endline ("Failed to read " ^ name) - + Printf.fprintf stderr "Failed to read %s\n" name; + exit !rc; From 41f4431a6ebdcb2f97fe9ada52c3a2be1ee3eb83 Mon Sep 17 00:00:00 2001 From: Andrew Cooper Date: Mon, 18 Nov 2013 14:49:40 +0000 Subject: [PATCH 013/260] Fix up tabs vs spaces --- networkd_db/networkd_db.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/networkd_db/networkd_db.ml b/networkd_db/networkd_db.ml index 389937ad7..33d5dfc71 100644 --- a/networkd_db/networkd_db.ml +++ b/networkd_db/networkd_db.ml @@ -20,7 +20,7 @@ let name = "networkd_db" let _ = let bridge = ref "" in let iface = ref "" in - let rc = ref 0 in + let rc = ref 0 in Arg.parse (Arg.align [ "-bridge", Arg.Set_string bridge, "Bridge name"; "-iface", Arg.Set_string iface, "Interface name"; From e4757319b6dfd4ecc269e128f2b87bc707197d13 Mon Sep 17 00:00:00 2001 From: Andrew Cooper Date: Mon, 18 Nov 2013 15:14:54 +0000 Subject: [PATCH 014/260] Use begin/end blocks correctly. --- networkd_db/networkd_db.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/networkd_db/networkd_db.ml b/networkd_db/networkd_db.ml index 33d5dfc71..eb8ef08fa 100644 --- a/networkd_db/networkd_db.ml +++ b/networkd_db/networkd_db.ml @@ -35,10 +35,10 @@ let _ = let bridge_config = List.assoc !bridge config.bridge_config in let ifaces = List.flatten (List.map (fun (_, port) -> port.interfaces) bridge_config.ports) in Printf.printf "interfaces=%s\n" (String.concat "," ifaces) - end else + end else begin rc := 1; Printf.fprintf stderr "Could not find bridge %s\n" !bridge; - + end; if !iface <> "" then if List.mem_assoc !iface config.interface_config then begin let interface_config = List.assoc !iface config.interface_config in @@ -94,9 +94,10 @@ let _ = in let data = datav4 @ datav6 in List.iter (fun (k, v) -> Printf.printf "%s=%s\n" k v) data - end else + end else begin rc := 1; Printf.fprintf stderr "Could not find interface %s\n" !iface; + end; with Network_config.Read_error -> Printf.fprintf stderr "Failed to read %s\n" name; exit !rc; From 4cefb43004f858f2ae5eeb44ffe8e700250fec61 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Wed, 4 Dec 2013 14:40:43 +0000 Subject: [PATCH 015/260] add config file for network.conf to select the backend type Signed-off-by: Rob Hoes --- networkd/network_server.ml | 21 ++++++++++++--------- networkd/networkd.ml | 6 ++++++ 2 files changed, 18 insertions(+), 9 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index d0c2b1401..dbb7a31c6 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -24,6 +24,7 @@ open D type context = unit +let network_conf = ref "/etc/xcp/network.conf" let config : config_t ref = ref empty_config let legacy_management_interface_start () = @@ -396,15 +397,17 @@ module Bridge = struct config := {!config with bridge_config = update_config !config.bridge_config name data} let determine_backend () = - let backend = String.strip String.isspace - (Unixext.string_of_file ("/etc/xcp/network.conf")) in - match backend with - | "openvswitch" | "vswitch" -> kind := Openvswitch - | "bridge" -> kind := Bridge - | backend -> - let error = Printf.sprintf "ERROR: network backend unknown (%s)" backend in - debug "%s" error; - failwith error + try + let backend = String.strip String.isspace (Unixext.string_of_file !network_conf) in + match backend with + | "openvswitch" | "vswitch" -> kind := Openvswitch + | "bridge" -> kind := Bridge + | backend -> + warn "Network backend unknown (%s). Falling back to Open vSwitch." backend; + kind := Openvswitch + with _ -> + warn "Network-conf file not found. Falling back to Open vSwitch."; + kind := Openvswitch let get_bond_links_up _ dbg ~name = Debug.with_thread_associated dbg (fun () -> diff --git a/networkd/networkd.ml b/networkd/networkd.ml index f2d9762b7..a84680bb3 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -22,6 +22,12 @@ open D module Server = Network_interface.Server(Network_server) let resources = [ + { Xcp_service.name = "network-conf"; + description = "used to select the network backend"; + essential = true; + path = Network_server.network_conf; + perms = [ Unix.R_OK ]; + }; { Xcp_service.name = "brctl"; description = "used to set up bridges"; essential = true; From e976b03bbf5262cfb3c0e18382700396dcc54ef6 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Wed, 4 Dec 2013 17:44:11 +0000 Subject: [PATCH 016/260] CA-120846: fix get_mac for bonded interfaces When an interface is bonded by the Linux bonding driver, the driver may change the MAC address of the interface to that of the bond. The only place where you can find the "real" MAC address of a bond slave seems to be /proc/net/bonding. Signed-off-by: Rob Hoes --- lib/network_utils.ml | 52 ++++++++++++++++++++++++++++---------- networkd/network_server.ml | 4 ++- 2 files changed, 41 insertions(+), 15 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 7fa8bdc1e..7021cc743 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -445,6 +445,12 @@ module Linux_bonding = struct error "Failed to remove slave %s from bond %s" slave master else error "Bond %s does not exist; cannot remove slave" master + + let get_bond_master_of slave = + try + let path = Unix.readlink (Sysfs.getpath slave "master") in + Some (List.hd (List.rev (String.split '/' path))) + with _ -> None end module Dhclient = struct @@ -533,28 +539,46 @@ module Sysctl = struct end module Proc = struct - let get_bond_links_up name = + let get_bond_slave_info name key = try let raw = Unixext.string_of_file (bonding_dir ^ name) in let lines = String.split '\n' raw in let check_lines lines = - let rec loop acc = function - | [] -> acc - | line1 :: line2 :: tail -> - if (String.startswith "Slave Interface:" line1) - && (String.startswith "MII Status:" line2) - && (String.endswith "up" line2) - then - loop (acc + 1) tail - else - loop acc (line2 :: tail) - | _ :: [] -> acc in - loop 0 lines in + let rec loop current acc = function + | [] -> acc + | line :: tail -> + try + Scanf.sscanf line "%s@: %s@\n" (fun k v -> + if k = "Slave Interface" then begin + let interface = Some (String.strip String.isspace v) in + loop interface acc tail + end else if k = key then + match current with + | Some interface -> loop current ((interface, String.strip String.isspace v) :: acc) tail + | None -> loop current acc tail + else + loop current acc tail + ) + with _ -> + loop current acc tail + in + loop None [] lines + in check_lines lines with e -> error "Error: could not read %s." (bonding_dir ^ name); - 0 + [] + let get_bond_slave_mac name slave = + let macs = get_bond_slave_info name "Permanent HW addr" in + if List.mem_assoc slave macs then + List.assoc slave macs + else + raise Not_found + + let get_bond_links_up name = + let statusses = get_bond_slave_info name "MII Status" in + List.fold_left (fun x (_, y) -> x + (if y = "up" then 1 else 0)) 0 statusses end module Ovs = struct diff --git a/networkd/network_server.ml b/networkd/network_server.ml index dbb7a31c6..5f10c9d70 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -103,7 +103,9 @@ module Interface = struct let get_mac _ dbg ~name = Debug.with_thread_associated dbg (fun () -> - Ip.get_mac name + match Linux_bonding.get_bond_master_of name with + | Some master -> Proc.get_bond_slave_mac master name + | None -> Ip.get_mac name ) () let is_up _ dbg ~name = From 0248f1bec35bf2d75dba2988407275e704997228 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Wed, 29 Jan 2014 14:49:49 +0000 Subject: [PATCH 017/260] CA-114498: Linux bonding: set properties (e.g. mode) before adding slaves This is needed to get LACP bonding to work on the Linux bridge backend. Signed-off-by: Rob Hoes --- networkd/network_server.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 5f10c9d70..911affe25 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -637,18 +637,18 @@ module Bridge = struct end else begin if not (List.mem name (Sysfs.bridge_to_interfaces bridge)) then begin Linux_bonding.add_bond_master name; - List.iter (fun name -> Interface.bring_down () dbg ~name) interfaces; - List.iter (Linux_bonding.add_bond_slave name) interfaces; - begin match bond_mac with - | Some mac -> Ip.set_mac name mac - | None -> warn "No MAC address specified for the bond" - end; let bond_properties = if List.mem_assoc "mode" bond_properties && List.assoc "mode" bond_properties = "lacp" then List.replace_assoc "mode" "802.3ad" bond_properties else bond_properties in - Linux_bonding.set_bond_properties name bond_properties + Linux_bonding.set_bond_properties name bond_properties; + List.iter (fun name -> Interface.bring_down () dbg ~name) interfaces; + List.iter (Linux_bonding.add_bond_slave name) interfaces; + begin match bond_mac with + | Some mac -> Ip.set_mac name mac + | None -> warn "No MAC address specified for the bond" + end end; Interface.bring_up () dbg ~name; ignore (Brctl.create_port bridge name) From 0ce0e2de4b15fc1ee531e3d3fcd32dfa70ef1163 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Thu, 30 Jan 2014 17:56:58 +0000 Subject: [PATCH 018/260] CA-118425/SCTX-1559: Remove interfaces from bridge before creating VLAN on it This avoids problems in case the bridge already existed for some reason, e.g. because it was not cleaned up due to an earlier error condition. Signed-off-by: Rob Hoes --- networkd/network_server.ml | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 911affe25..a8c2bb357 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -481,11 +481,23 @@ module Bridge = struct match vlan with | None -> () | Some (parent, vlan) -> - let interface = List.hd (List.filter (fun n -> + (* Robustness enhancement: ensure there are no other VLANs in the bridge *) + let current_interfaces = List.filter (fun n -> + String.startswith "eth" n || String.startswith "bond" n + ) (Sysfs.bridge_to_interfaces name) in + debug "Removing these non-VIF interfaces found on the bridge: %s" + (String.concat ", " current_interfaces); + List.iter (fun interface -> + Brctl.destroy_port name interface; + Interface.bring_down () dbg ~name:interface + ) current_interfaces; + + (* Now create the new VLAN device and add it to the bridge *) + let parent_interface = List.hd (List.filter (fun n -> String.startswith "eth" n || String.startswith "bond" n ) (Sysfs.bridge_to_interfaces parent)) in - Ip.create_vlan interface vlan; - let vlan_name = Ip.vlan_name interface vlan in + Ip.create_vlan parent_interface vlan; + let vlan_name = Ip.vlan_name parent_interface vlan in Interface.bring_up () dbg ~name:vlan_name; Brctl.create_port name vlan_name end; From 96baefe6b5ea85925fa54f7e65d359be95a3c771 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Wed, 7 May 2014 10:54:57 +0100 Subject: [PATCH 019/260] s/Stringext/Xstringext/g Signed-off-by: Jon Ludlam --- lib/network_config.ml | 2 +- lib/network_utils.ml | 2 +- networkd/network_monitor.ml | 2 +- networkd/network_monitor_thread.ml | 2 +- networkd/network_server.ml | 2 +- test/network_test_lacp_properties.ml | 4 ++-- 6 files changed, 7 insertions(+), 7 deletions(-) diff --git a/lib/network_config.ml b/lib/network_config.ml index 186a21127..2993e7513 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -15,7 +15,7 @@ open Network_interface open Fun -open Stringext +open Xstringext module D = Debug.Make(struct let name = "network_config" end) open D diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 7021cc743..90ab69791 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -13,7 +13,7 @@ *) open Listext -open Stringext +open Xstringext open Fun open Network_interface diff --git a/networkd/network_monitor.ml b/networkd/network_monitor.ml index 4e136840f..fc6921683 100644 --- a/networkd/network_monitor.ml +++ b/networkd/network_monitor.ml @@ -16,7 +16,7 @@ open Network_interface include Network_stats open Fun -open Stringext +open Xstringext open Threadext let write_stats stats = diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index 1bf727454..606fd250b 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -15,7 +15,7 @@ open Network_utils open Fun -open Stringext +open Xstringext open Listext open Threadext diff --git a/networkd/network_server.ml b/networkd/network_server.ml index a8c2bb357..5b7b96e59 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -16,7 +16,7 @@ open Network_utils open Network_interface open Fun -open Stringext +open Xstringext open Listext module D = Debug.Make(struct let name = "network_server" end) diff --git a/test/network_test_lacp_properties.ml b/test/network_test_lacp_properties.ml index a07b5f0c6..0ed52f626 100644 --- a/test/network_test_lacp_properties.ml +++ b/test/network_test_lacp_properties.ml @@ -91,7 +91,7 @@ let test_lacp_aggregation_key_vsctl arg () = skip_if true "Unimplemented" ; print_endline answer ; assert_bool "lacp_aggregation_key is passed to ovs-vsctl command" (List.exists - (fun s -> (Stringext.String.(strip isspace s) == answer)) + (fun s -> (Xstringext.String.(strip isspace s) == answer)) !OVS_Cli_test.vsctl_output) (* Test case for bond_create with default lacp-{time,aggregation-key} settings. @@ -115,7 +115,7 @@ let test_lacp_defaults_bond_create () = List.iter (fun arg -> assert_bool "key=value argument pairs can't have missing values" - (let open Stringext.String in + (let open Xstringext.String in arg |> strip isspace |> endswith "=" |> not)) !OVS_Cli_test.vsctl_output From fd4bf9f5019a21d897b6babfda2f77a1861d66ac Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Tue, 3 Jun 2014 18:33:50 +0100 Subject: [PATCH 020/260] Release 0.9.4 Signed-off-by: Jon Ludlam --- ChangeLog | 10 + Makefile | 30 +- _oasis | 47 + _tags | 89 + lib/META | 18 +- lib/libnetworklibs_stubs.clib | 4 + lib/networklibs.mldylib | 5 + lib/networklibs.mllib | 5 + myocamlbuild.ml | 625 +++ networkd/network_server.ml | 2 +- setup.ml | 7052 +++++++++++++++++++++++++++++++++ 11 files changed, 7869 insertions(+), 18 deletions(-) create mode 100644 _oasis create mode 100644 _tags create mode 100644 lib/libnetworklibs_stubs.clib create mode 100644 lib/networklibs.mldylib create mode 100644 lib/networklibs.mllib create mode 100644 myocamlbuild.ml create mode 100644 setup.ml diff --git a/ChangeLog b/ChangeLog index d066396a8..2731b252a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +0.9.4 (3-Jun-2014): +* Use oasis for building +* Update to new stdext interface +* Fix CA-118425/SCTX-1559: An earlier error could cause problems with VLANs +* Enable LACP bonding on linux bridge +* Fix CA-116420: Bonds were getting incorrect MAC addresses on 3.x kernels +* Fix CA-120846: Finding MAC addresses for bonds +* Fix CA-105789: Bridge had incorrect MAC address on first boot +* Fix CA-121503: Pay attention to return codes from subprocesses (Andrew Cooper) + 0.9.3 (24-Sep-2013): * Allow the Bond.create to carry on even if the MTU size is invalid * network monitor: better represent duplex mode for NIC bonds diff --git a/Makefile b/Makefile index e449a9e64..819ea638e 100644 --- a/Makefile +++ b/Makefile @@ -1,23 +1,37 @@ BINDIR ?= /usr/bin SBINDIR ?= /usr/sbin ETCDIR ?= /etc +all: build doc .PHONY: test install uninstall clean -dist/build/xcp-networkd/xcp-networkd: - obuild configure --enable-tests - obuild build +export OCAMLRUNPARAM=b +J=4 -test: - obuild test --output +setup.bin: setup.ml + @ocamlopt.opt -o $@ $< || ocamlopt -o $@ $< || ocamlc -o $@ $< + @rm -f setup.cmx setup.cmi setup.o setup.cmo + +setup.data: setup.bin + @./setup.bin -configure --enable-tests + +build: setup.data setup.bin + @./setup.bin -build -j $(J) + +doc: setup.data setup.bin + @./setup.bin -doc -j $(J) + +test: setup.bin build + @./setup.bin -test install: - install -D dist/build/xcp-networkd/xcp-networkd $(DESTDIR)$(SBINDIR)/xcp-networkd - install -D dist/build/networkd_db/networkd_db $(DESTDIR)$(BINDIR)/networkd_db + install -D networkd.native $(DESTDIR)$(SBINDIR)/xcp-networkd + install -D networkd_db.native $(DESTDIR)$(BINDIR)/networkd_db uninstall: rm -f $(DESTDIR)$(SBINDIR)/xcp-networkd rm -f $(DESTDIR)$(SBINDIR)/networkd_db clean: - rm -rf dist + @ocamlbuild -clean + @rm -f setup.data setup.log setup.bin diff --git a/_oasis b/_oasis new file mode 100644 index 000000000..bf17b223b --- /dev/null +++ b/_oasis @@ -0,0 +1,47 @@ +OASISFormat: 0.3 +Name: xcp-networkd +Version: 0.9.4 +Synopsis: XCP Network Daemon +Authors: Rob Hoes +License: LGPL-2.1 with OCaml linking exception +Plugins: META (0.2) +BuildTools: ocamlbuild + +Library networklibs + CompiledObject: best + Path: lib + Findlibname: network-libs + Modules: Network_config, Network_utils + BuildDepends: forkexec, stdext, threads, rpclib, stdext, xcp-inventory, xcp.network + CSources: link_stubs.c, netdev.h + CCOpt: -Wno-unused-function -g -ggdb + +Executable xcp_networkd + CompiledObject: best + Path: networkd + MainIs: networkd.ml + Custom: true + Install: false + BuildDepends: threads, rpclib, rpclib.unix, forkexec, stdext, xcp-inventory, network-libs, xen-api-client, xcp, xcp.network + +Executable networkd_db + CompiledObject: best + Path: networkd_db + MainIs: networkd_db.ml + Custom: true + Install: false + BuildDepends: network-libs, stdext, threads, xcp.network + +Executable network_test + CompiledObject: best + Path: test + MainIs: network_test.ml + Install: false + BuildDepends: stdext, oUnit, network-libs + +Test test_networkd + Run$: flag(tests) + Command: $network_test + WorkingDirectory: . + + diff --git a/_tags b/_tags new file mode 100644 index 000000000..34f629423 --- /dev/null +++ b/_tags @@ -0,0 +1,89 @@ +# OASIS_START +# DO NOT EDIT (digest: 6dce1a9a50f608514e51caf58ef0ebc9) +# 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 +<**/.svn>: -traverse +<**/.svn>: not_hygienic +".bzr": -traverse +".bzr": not_hygienic +".hg": -traverse +".hg": not_hygienic +".git": -traverse +".git": not_hygienic +"_darcs": -traverse +"_darcs": not_hygienic +# Library networklibs +"lib/networklibs.cmxs": use_networklibs +: oasis_library_networklibs_ccopt +"lib/link_stubs.c": oasis_library_networklibs_ccopt +: use_libnetworklibs_stubs +: pkg_forkexec +: pkg_rpclib +: pkg_stdext +: pkg_threads +: pkg_xcp-inventory +: pkg_xcp.network +"lib/link_stubs.c": pkg_forkexec +"lib/link_stubs.c": pkg_rpclib +"lib/link_stubs.c": pkg_stdext +"lib/link_stubs.c": pkg_threads +"lib/link_stubs.c": pkg_xcp-inventory +"lib/link_stubs.c": pkg_xcp.network +# Executable xcp_networkd +: pkg_forkexec +: pkg_rpclib +: pkg_rpclib.unix +: pkg_stdext +: pkg_threads +: pkg_xcp +: pkg_xcp-inventory +: pkg_xcp.network +: pkg_xen-api-client +: use_networklibs +: pkg_forkexec +: pkg_rpclib +: pkg_rpclib.unix +: pkg_stdext +: pkg_threads +: pkg_xcp +: pkg_xcp-inventory +: pkg_xcp.network +: pkg_xen-api-client +: use_networklibs +: custom +# Executable networkd_db +: pkg_forkexec +: pkg_rpclib +: pkg_stdext +: pkg_threads +: pkg_xcp-inventory +: pkg_xcp.network +: use_networklibs +: pkg_forkexec +: pkg_rpclib +: pkg_stdext +: pkg_threads +: pkg_xcp-inventory +: pkg_xcp.network +: use_networklibs +: custom +# Executable network_test +: pkg_forkexec +: pkg_oUnit +: pkg_rpclib +: pkg_stdext +: pkg_threads +: pkg_xcp-inventory +: pkg_xcp.network +: use_networklibs +: pkg_forkexec +: pkg_oUnit +: pkg_rpclib +: pkg_stdext +: pkg_threads +: pkg_xcp-inventory +: pkg_xcp.network +: use_networklibs +# OASIS_STOP + diff --git a/lib/META b/lib/META index c73201d12..c6a36cffc 100644 --- a/lib/META +++ b/lib/META @@ -1,12 +1,12 @@ # OASIS_START -# DO NOT EDIT (digest: 5476962f222c44a9e65ebd154950f9cc) -version = "0.1.0" -description = "The XCP networking daemon" -requires = "threads rpclib log stdext xcp-inventory xcp.network" -archive(byte) = "xcp-networkd.cma" -archive(byte, plugin) = "xcp-networkd.cma" -archive(native) = "xcp-networkd.cmxa" -archive(native, plugin) = "xcp-networkd.cmxs" -exists_if = "xcp-networkd.cma" +# DO NOT EDIT (digest: 91b748c7a2332c0932eed83315151278) +version = "0.9.4" +description = "XCP Network Daemon" +requires = "forkexec stdext threads rpclib stdext xcp-inventory xcp.network" +archive(byte) = "networklibs.cma" +archive(byte, plugin) = "networklibs.cma" +archive(native) = "networklibs.cmxa" +archive(native, plugin) = "networklibs.cmxs" +exists_if = "networklibs.cma" # OASIS_STOP diff --git a/lib/libnetworklibs_stubs.clib b/lib/libnetworklibs_stubs.clib new file mode 100644 index 000000000..4af8b9516 --- /dev/null +++ b/lib/libnetworklibs_stubs.clib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 2eec6769d0c3db5ab2748de2ec73c768) +link_stubs.o +# OASIS_STOP diff --git a/lib/networklibs.mldylib b/lib/networklibs.mldylib new file mode 100644 index 000000000..465d4b7bd --- /dev/null +++ b/lib/networklibs.mldylib @@ -0,0 +1,5 @@ +# OASIS_START +# DO NOT EDIT (digest: 769536bab5c8cdff920a6b9ddafec2e2) +Network_config +Network_utils +# OASIS_STOP diff --git a/lib/networklibs.mllib b/lib/networklibs.mllib new file mode 100644 index 000000000..465d4b7bd --- /dev/null +++ b/lib/networklibs.mllib @@ -0,0 +1,5 @@ +# OASIS_START +# DO NOT EDIT (digest: 769536bab5c8cdff920a6b9ddafec2e2) +Network_config +Network_utils +# OASIS_STOP diff --git a/myocamlbuild.ml b/myocamlbuild.ml new file mode 100644 index 000000000..8ec5d77b9 --- /dev/null +++ b/myocamlbuild.ml @@ -0,0 +1,625 @@ +(* OASIS_START *) +(* DO NOT EDIT (digest: 1b562e89c2fc3873269cda485f3abe87) *) +module OASISGettext = struct +(* # 22 "src/oasis/OASISGettext.ml" *) + + + let ns_ str = + str + + + let s_ str = + str + + + let f_ (str: ('a, 'b, 'c, 'd) format4) = + str + + + let fn_ fmt1 fmt2 n = + if n = 1 then + fmt1^^"" + else + fmt2^^"" + + + let init = + [] + + +end + +module OASISExpr = struct +(* # 22 "src/oasis/OASISExpr.ml" *) + + + + + + open OASISGettext + + + type test = string + + + type flag = string + + + type t = + | EBool of bool + | ENot of t + | EAnd of t * t + | EOr of t * t + | EFlag of flag + | ETest of test * string + + + + type 'a choices = (t * 'a) list + + + let eval var_get t = + let rec eval' = + function + | EBool b -> + b + + | ENot e -> + not (eval' e) + + | EAnd (e1, e2) -> + (eval' e1) && (eval' e2) + + | EOr (e1, e2) -> + (eval' e1) || (eval' e2) + + | EFlag nm -> + let v = + var_get nm + in + assert(v = "true" || v = "false"); + (v = "true") + + | ETest (nm, vl) -> + let v = + var_get nm + in + (v = vl) + in + eval' t + + + let choose ?printer ?name var_get lst = + let rec choose_aux = + function + | (cond, vl) :: tl -> + if eval var_get cond then + vl + else + choose_aux tl + | [] -> + let str_lst = + if lst = [] then + s_ "" + else + String.concat + (s_ ", ") + (List.map + (fun (cond, vl) -> + match printer with + | Some p -> p vl + | None -> s_ "") + lst) + in + match name with + | Some nm -> + failwith + (Printf.sprintf + (f_ "No result for the choice list '%s': %s") + nm str_lst) + | None -> + failwith + (Printf.sprintf + (f_ "No result for a choice list: %s") + str_lst) + in + choose_aux (List.rev lst) + + +end + + +# 132 "myocamlbuild.ml" +module BaseEnvLight = struct +(* # 22 "src/base/BaseEnvLight.ml" *) + + + module MapString = Map.Make(String) + + + type t = string MapString.t + + + let default_filename = + Filename.concat + (Sys.getcwd ()) + "setup.data" + + + let load ?(allow_empty=false) ?(filename=default_filename) () = + if Sys.file_exists filename then + begin + let chn = + open_in_bin filename + in + let st = + Stream.of_channel chn + in + let line = + ref 1 + in + let st_line = + Stream.from + (fun _ -> + try + match Stream.next st with + | '\n' -> incr line; Some '\n' + | c -> Some c + with Stream.Failure -> None) + in + let lexer = + Genlex.make_lexer ["="] st_line + in + let rec read_file mp = + match Stream.npeek 3 lexer with + | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> + Stream.junk lexer; + Stream.junk lexer; + Stream.junk lexer; + read_file (MapString.add nm value mp) + | [] -> + mp + | _ -> + failwith + (Printf.sprintf + "Malformed data file '%s' line %d" + filename !line) + in + let mp = + read_file MapString.empty + in + close_in chn; + mp + end + else if allow_empty then + begin + MapString.empty + end + else + begin + failwith + (Printf.sprintf + "Unable to load environment, the file '%s' doesn't exist." + filename) + end + + + let rec var_expand str env = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) env + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + + + let var_get name env = + var_expand (MapString.find name env) env + + + let var_choose lst env = + OASISExpr.choose + (fun nm -> var_get nm env) + lst +end + + +# 237 "myocamlbuild.ml" +module MyOCamlbuildFindlib = struct +(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) + + + (** OCamlbuild extension, copied from + * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild + * by N. Pouillard and others + * + * Updated on 2009/02/28 + * + * Modified by Sylvain Le Gall + *) + open Ocamlbuild_plugin + + + (* these functions are not really officially exported *) + let run_and_read = + Ocamlbuild_pack.My_unix.run_and_read + + + let blank_sep_strings = + Ocamlbuild_pack.Lexers.blank_sep_strings + + + let exec_from_conf exec = + let exec = + let env_filename = Pathname.basename BaseEnvLight.default_filename in + let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in + try + BaseEnvLight.var_get exec env + with Not_found -> + Printf.eprintf "W: Cannot get variable %s\n" exec; + exec + in + let fix_win32 str = + if Sys.os_type = "Win32" then begin + let buff = Buffer.create (String.length str) in + (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. + *) + String.iter + (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) + str; + Buffer.contents buff + end else begin + str + end + in + fix_win32 exec + + let split s ch = + let buf = Buffer.create 13 in + let x = ref [] in + let flush () = + x := (Buffer.contents buf) :: !x; + Buffer.clear buf + in + 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' + + + let before_space s = + try + String.before s (String.index s ' ') + with Not_found -> s + + (* ocamlfind command *) + let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] + + (* This lists all supported packages. *) + let find_packages () = + List.map before_space (split_nl & run_and_read "ocamlfind list") + + + (* Mock to list available syntaxes. *) + let find_syntaxes () = ["camlp4o"; "camlp4r"] + + + let well_known_syntax = [ + "camlp4.quotations.o"; + "camlp4.quotations.r"; + "camlp4.exceptiontracer"; + "camlp4.extend"; + "camlp4.foldgenerator"; + "camlp4.listcomprehension"; + "camlp4.locationstripper"; + "camlp4.macro"; + "camlp4.mapgenerator"; + "camlp4.metagenerator"; + "camlp4.profiler"; + "camlp4.tracer" + ] + + + let dispatch = + function + | After_options -> + (* By using Before_options one let command line options have an higher + * priority on the contrary using After_options will guarantee to have + * the higher priority override default commands by ocamlfind ones *) + Options.ocamlc := ocamlfind & A"ocamlc"; + Options.ocamlopt := ocamlfind & A"ocamlopt"; + Options.ocamldep := ocamlfind & A"ocamldep"; + Options.ocamldoc := ocamlfind & A"ocamldoc"; + Options.ocamlmktop := ocamlfind & A"ocamlmktop"; + Options.ocamlmklib := ocamlfind & A"ocamlmklib" + + | After_rules -> + + (* When one link an OCaml library/binary/package, one should use + * -linkpkg *) + flag ["ocaml"; "link"; "program"] & 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 + (* TODO: consider how to really choose camlp4o or camlp4r. *) + 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" || + List.mem pkg well_known_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 ()); + + (* Like -package but for extensions syntax. Morover -syntax is useless + * when linking. *) + List.iter begin fun syntax -> + flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & + S[A"-syntax"; A syntax]; + end (find_syntaxes ()); + + (* The default "thread" tag is not compatible with ocamlfind. + * Indeed, the default rules add the "threads.cma" or "threads.cmxa" + * options when using this tag. When using the "-linkpkg" option with + * ocamlfind, this module will then be added twice on the command line. + * + * To solve this, one approach is to add the "-thread" option when using + * the "threads" package using the previous plugin. + *) + flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); + flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); + flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); + flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); + flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); + + | _ -> + () +end + +module MyOCamlbuildBase = struct +(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) + + + (** Base functions for writing myocamlbuild.ml + @author Sylvain Le Gall + *) + + + + + + open Ocamlbuild_plugin + module OC = Ocamlbuild_pack.Ocaml_compiler + + + type dir = string + type file = string + type name = string + type tag = string + + +(* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) + + + type t = + { + lib_ocaml: (name * dir list * string list) list; + lib_c: (name * dir * file list) list; + flags: (tag list * (spec OASISExpr.choices)) list; + (* Replace the 'dir: include' from _tags by a precise interdepends in + * directory. + *) + includes: (dir * dir list) list; + } + + + let env_filename = + Pathname.basename + BaseEnvLight.default_filename + + + let dispatch_combine lst = + fun e -> + List.iter + (fun dispatch -> dispatch e) + lst + + + let tag_libstubs nm = + "use_lib"^nm^"_stubs" + + + let nm_libstubs nm = + nm^"_stubs" + + + let dispatch t e = + let env = + BaseEnvLight.load + ~filename:env_filename + ~allow_empty:true + () + in + match e with + | Before_options -> + let no_trailing_dot s = + if String.length s >= 1 && s.[0] = '.' then + String.sub s 1 ((String.length s) - 1) + else + s + in + List.iter + (fun (opt, var) -> + try + opt := no_trailing_dot (BaseEnvLight.var_get var env) + with Not_found -> + Printf.eprintf "W: Cannot get variable %s\n" var) + [ + Options.ext_obj, "ext_obj"; + Options.ext_lib, "ext_lib"; + Options.ext_dll, "ext_dll"; + ] + + | After_rules -> + (* Declare OCaml libraries *) + List.iter + (function + | nm, [], intf_modules -> + ocaml_lib nm; + let cmis = + List.map (fun m -> (String.uncapitalize m) ^ ".cmi") + intf_modules in + dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis + | nm, dir :: tl, intf_modules -> + ocaml_lib ~dir:dir (dir^"/"^nm); + List.iter + (fun dir -> + List.iter + (fun str -> + flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) + ["compile"; "infer_interface"; "doc"]) + tl; + let cmis = + List.map (fun m -> dir^"/"^(String.uncapitalize m)^".cmi") + intf_modules in + dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] + cmis) + t.lib_ocaml; + + (* Declare directories dependencies, replace "include" in _tags. *) + List.iter + (fun (dir, include_dirs) -> + Pathname.define_context dir include_dirs) + t.includes; + + (* Declare C libraries *) + List.iter + (fun (lib, dir, headers) -> + (* Handle C part of library *) + flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] + (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; + A("-l"^(nm_libstubs lib))]); + + flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] + (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); + + flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] + (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); + + (* When ocaml link something that use the C library, then one + need that file to be up to date. + *) + dep ["link"; "ocaml"; "program"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + + dep ["compile"; "ocaml"; "program"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + + (* TODO: be more specific about what depends on headers *) + (* Depends on .h files *) + dep ["compile"; "c"] + headers; + + (* Setup search path for lib *) + flag ["link"; "ocaml"; "use_"^lib] + (S[A"-I"; P(dir)]); + ) + t.lib_c; + + (* Add flags *) + List.iter + (fun (tags, cond_specs) -> + let spec = BaseEnvLight.var_choose cond_specs env in + let rec eval_specs = + function + | S lst -> S (List.map eval_specs lst) + | A str -> A (BaseEnvLight.var_expand str env) + | spec -> spec + in + flag tags & (eval_specs spec)) + t.flags + | _ -> + () + + + let dispatch_default t = + dispatch_combine + [ + dispatch t; + MyOCamlbuildFindlib.dispatch; + ] + + +end + + +# 594 "myocamlbuild.ml" +open Ocamlbuild_plugin;; +let package_default = + { + MyOCamlbuildBase.lib_ocaml = [("networklibs", ["lib"], [])]; + lib_c = [("networklibs", "lib", ["lib/netdev.h"])]; + flags = + [ + (["oasis_library_networklibs_ccopt"; "compile"], + [ + (OASISExpr.EBool true, + S + [ + A "-ccopt"; + A "-Wno-unused-function"; + A "-ccopt"; + A "-g"; + A "-ccopt"; + A "-ggdb" + ]) + ]) + ]; + includes = + [("test", ["lib"]); ("networkd_db", ["lib"]); ("networkd", ["lib"])] + } + ;; + +let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; + +# 624 "myocamlbuild.ml" +(* OASIS_STOP *) +Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 5b7b96e59..969413d3c 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -431,7 +431,7 @@ module Bridge = struct | None -> "" | Some (parent, vlan) -> Printf.sprintf " (VLAN %d on bridge %s)" vlan parent ); - update_config name {get_config name with vlan; bridge_mac=mac; other_config}; + update_config name {(get_config name) with vlan; bridge_mac=mac; other_config}; begin match !kind with | Openvswitch -> let fail_mode = diff --git a/setup.ml b/setup.ml new file mode 100644 index 000000000..c274d211b --- /dev/null +++ b/setup.ml @@ -0,0 +1,7052 @@ +(* setup.ml generated for the first time by OASIS v0.4.4 *) + +(* OASIS_START *) +(* DO NOT EDIT (digest: 8a544e6f7b2bc3fb2f97d5be41f7b1aa) *) +(* + Regenerated by OASIS v0.4.4 + Visit http://oasis.forge.ocamlcore.org for more information and + documentation about functions used in this file. +*) +module OASISGettext = struct +(* # 22 "src/oasis/OASISGettext.ml" *) + + + let ns_ str = + str + + + let s_ str = + str + + + let f_ (str: ('a, 'b, 'c, 'd) format4) = + str + + + let fn_ fmt1 fmt2 n = + if n = 1 then + fmt1^^"" + else + fmt2^^"" + + + let init = + [] + + +end + +module OASISContext = struct +(* # 22 "src/oasis/OASISContext.ml" *) + + + open OASISGettext + + + type level = + [ `Debug + | `Info + | `Warning + | `Error] + + + type t = + { + (* TODO: replace this by a proplist. *) + quiet: bool; + info: bool; + debug: bool; + ignore_plugins: bool; + ignore_unknown_fields: bool; + printf: level -> string -> unit; + } + + + let printf lvl str = + let beg = + match lvl with + | `Error -> s_ "E: " + | `Warning -> s_ "W: " + | `Info -> s_ "I: " + | `Debug -> s_ "D: " + in + prerr_endline (beg^str) + + + let default = + ref + { + quiet = false; + info = false; + debug = false; + ignore_plugins = false; + ignore_unknown_fields = false; + printf = printf; + } + + + let quiet = + {!default with quiet = true} + + + let fspecs () = + (* TODO: don't act on default. *) + let ignore_plugins = ref false in + ["-quiet", + Arg.Unit (fun () -> default := {!default with quiet = true}), + s_ " Run quietly"; + + "-info", + Arg.Unit (fun () -> default := {!default with info = true}), + s_ " Display information message"; + + + "-debug", + Arg.Unit (fun () -> default := {!default with debug = true}), + s_ " Output debug message"; + + "-ignore-plugins", + Arg.Set ignore_plugins, + s_ " Ignore plugin's field."; + + "-C", + (* TODO: remove this chdir. *) + Arg.String (fun str -> Sys.chdir str), + s_ "dir Change directory before running."], + fun () -> {!default with ignore_plugins = !ignore_plugins} +end + +module OASISString = struct +(* # 22 "src/oasis/OASISString.ml" *) + + + (** Various string utilities. + + Mostly inspired by extlib and batteries ExtString and BatString libraries. + + @author Sylvain Le Gall + *) + + + let nsplitf str f = + if str = "" then + [] + else + let buf = Buffer.create 13 in + let lst = ref [] in + let push () = + lst := Buffer.contents buf :: !lst; + Buffer.clear buf + in + let str_len = String.length str in + for i = 0 to str_len - 1 do + if f str.[i] then + push () + else + Buffer.add_char buf str.[i] + done; + push (); + List.rev !lst + + + (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the + separator. + *) + let nsplit str c = + nsplitf str ((=) c) + + + let find ~what ?(offset=0) str = + let what_idx = ref 0 in + let str_idx = ref offset in + while !str_idx < String.length str && + !what_idx < String.length what do + if str.[!str_idx] = what.[!what_idx] then + incr what_idx + else + what_idx := 0; + incr str_idx + done; + if !what_idx <> String.length what then + raise Not_found + else + !str_idx - !what_idx + + + let sub_start str len = + let str_len = String.length str in + if len >= str_len then + "" + else + String.sub str len (str_len - len) + + + let sub_end ?(offset=0) str len = + let str_len = String.length str in + if len >= str_len then + "" + else + String.sub str 0 (str_len - len) + + + let starts_with ~what ?(offset=0) str = + let what_idx = ref 0 in + let str_idx = ref offset in + let ok = ref true in + while !ok && + !str_idx < String.length str && + !what_idx < String.length what do + if str.[!str_idx] = what.[!what_idx] then + incr what_idx + else + ok := false; + incr str_idx + done; + if !what_idx = String.length what then + true + else + false + + + let strip_starts_with ~what str = + if starts_with ~what str then + sub_start str (String.length what) + else + raise Not_found + + + let ends_with ~what ?(offset=0) str = + let what_idx = ref ((String.length what) - 1) in + let str_idx = ref ((String.length str) - 1) in + let ok = ref true in + while !ok && + offset <= !str_idx && + 0 <= !what_idx do + if str.[!str_idx] = what.[!what_idx] then + decr what_idx + else + ok := false; + decr str_idx + done; + if !what_idx = -1 then + true + else + false + + + let strip_ends_with ~what str = + if ends_with ~what str then + sub_end str (String.length what) + else + raise Not_found + + + let replace_chars f s = + let buf = String.make (String.length s) 'X' in + for i = 0 to String.length s - 1 do + buf.[i] <- f s.[i] + done; + buf + + +end + +module OASISUtils = struct +(* # 22 "src/oasis/OASISUtils.ml" *) + + + open OASISGettext + + + module MapExt = + struct + module type S = + sig + include Map.S + val add_list: 'a t -> (key * 'a) list -> 'a t + val of_list: (key * 'a) list -> 'a t + val to_list: 'a t -> (key * 'a) list + end + + module Make (Ord: Map.OrderedType) = + struct + include Map.Make(Ord) + + let rec add_list t = + function + | (k, v) :: tl -> add_list (add k v t) tl + | [] -> t + + let of_list lst = add_list empty lst + + let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] + end + end + + + module MapString = MapExt.Make(String) + + + module SetExt = + struct + module type S = + sig + include Set.S + val add_list: t -> elt list -> t + val of_list: elt list -> t + val to_list: t -> elt list + end + + module Make (Ord: Set.OrderedType) = + struct + include Set.Make(Ord) + + let rec add_list t = + function + | e :: tl -> add_list (add e t) tl + | [] -> t + + let of_list lst = add_list empty lst + + let to_list = elements + end + end + + + module SetString = SetExt.Make(String) + + + let compare_csl s1 s2 = + String.compare (String.lowercase s1) (String.lowercase s2) + + + module HashStringCsl = + Hashtbl.Make + (struct + type t = string + + let equal s1 s2 = + (String.lowercase s1) = (String.lowercase s2) + + let hash s = + Hashtbl.hash (String.lowercase s) + end) + + module SetStringCsl = + SetExt.Make + (struct + type t = string + let compare = compare_csl + end) + + + let varname_of_string ?(hyphen='_') s = + if String.length s = 0 then + begin + invalid_arg "varname_of_string" + end + else + begin + let buf = + OASISString.replace_chars + (fun c -> + if ('a' <= c && c <= 'z') + || + ('A' <= c && c <= 'Z') + || + ('0' <= c && c <= '9') then + c + else + hyphen) + s; + in + let buf = + (* Start with a _ if digit *) + if '0' <= s.[0] && s.[0] <= '9' then + "_"^buf + else + buf + in + String.lowercase buf + end + + + let varname_concat ?(hyphen='_') p s = + let what = String.make 1 hyphen in + let p = + try + OASISString.strip_ends_with ~what p + with Not_found -> + p + in + let s = + try + OASISString.strip_starts_with ~what s + with Not_found -> + s + in + p^what^s + + + let is_varname str = + str = varname_of_string str + + + let failwithf fmt = Printf.ksprintf failwith fmt + + +end + +module PropList = struct +(* # 22 "src/oasis/PropList.ml" *) + + + open OASISGettext + + + type name = string + + + exception Not_set of name * string option + exception No_printer of name + exception Unknown_field of name * name + + + let () = + Printexc.register_printer + (function + | Not_set (nm, Some rsn) -> + Some + (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) + | Not_set (nm, None) -> + Some + (Printf.sprintf (f_ "Field '%s' is not set") nm) + | No_printer nm -> + Some + (Printf.sprintf (f_ "No default printer for value %s") nm) + | Unknown_field (nm, schm) -> + Some + (Printf.sprintf + (f_ "Field %s is not defined in schema %s") nm schm) + | _ -> + None) + + + module Data = + struct + type t = + (name, unit -> unit) Hashtbl.t + + let create () = + Hashtbl.create 13 + + let clear t = + Hashtbl.clear t + + +(* # 78 "src/oasis/PropList.ml" *) + end + + + module Schema = + struct + type ('ctxt, 'extra) value = + { + get: Data.t -> string; + set: Data.t -> ?context:'ctxt -> string -> unit; + help: (unit -> string) option; + extra: 'extra; + } + + type ('ctxt, 'extra) t = + { + name: name; + fields: (name, ('ctxt, 'extra) value) Hashtbl.t; + order: name Queue.t; + name_norm: string -> string; + } + + let create ?(case_insensitive=false) nm = + { + name = nm; + fields = Hashtbl.create 13; + order = Queue.create (); + name_norm = + (if case_insensitive then + String.lowercase + else + fun s -> s); + } + + let add t nm set get extra help = + let key = + t.name_norm nm + in + + if Hashtbl.mem t.fields key then + failwith + (Printf.sprintf + (f_ "Field '%s' is already defined in schema '%s'") + nm t.name); + Hashtbl.add + t.fields + key + { + set = set; + get = get; + help = help; + extra = extra; + }; + Queue.add nm t.order + + let mem t nm = + Hashtbl.mem t.fields nm + + let find t nm = + try + Hashtbl.find t.fields (t.name_norm nm) + with Not_found -> + raise (Unknown_field (nm, t.name)) + + let get t data nm = + (find t nm).get data + + let set t data nm ?context x = + (find t nm).set + data + ?context + x + + let fold f acc t = + Queue.fold + (fun acc k -> + let v = + find t k + in + f acc k v.extra v.help) + acc + t.order + + let iter f t = + fold + (fun () -> f) + () + t + + let name t = + t.name + end + + + module Field = + struct + type ('ctxt, 'value, 'extra) t = + { + set: Data.t -> ?context:'ctxt -> 'value -> unit; + get: Data.t -> 'value; + sets: Data.t -> ?context:'ctxt -> string -> unit; + gets: Data.t -> string; + help: (unit -> string) option; + extra: 'extra; + } + + let new_id = + let last_id = + ref 0 + in + fun () -> incr last_id; !last_id + + let create ?schema ?name ?parse ?print ?default ?update ?help extra = + (* Default value container *) + let v = + ref None + in + + (* If name is not given, create unique one *) + let nm = + match name with + | Some s -> s + | None -> Printf.sprintf "_anon_%d" (new_id ()) + in + + (* Last chance to get a value: the default *) + let default () = + match default with + | Some d -> d + | None -> raise (Not_set (nm, Some (s_ "no default value"))) + in + + (* Get data *) + let get data = + (* Get value *) + try + (Hashtbl.find data nm) (); + match !v with + | Some x -> x + | None -> default () + with Not_found -> + default () + in + + (* Set data *) + let set data ?context x = + let x = + match update with + | Some f -> + begin + try + f ?context (get data) x + with Not_set _ -> + x + end + | None -> + x + in + Hashtbl.replace + data + nm + (fun () -> v := Some x) + in + + (* Parse string value, if possible *) + let parse = + match parse with + | Some f -> + f + | None -> + fun ?context s -> + failwith + (Printf.sprintf + (f_ "Cannot parse field '%s' when setting value %S") + nm + s) + in + + (* Set data, from string *) + let sets data ?context s = + set ?context data (parse ?context s) + in + + (* Output value as string, if possible *) + let print = + match print with + | Some f -> + f + | None -> + fun _ -> raise (No_printer nm) + in + + (* Get data, as a string *) + let gets data = + print (get data) + in + + begin + match schema with + | Some t -> + Schema.add t nm sets gets extra help + | None -> + () + end; + + { + set = set; + get = get; + sets = sets; + gets = gets; + help = help; + extra = extra; + } + + let fset data t ?context x = + t.set data ?context x + + let fget data t = + t.get data + + let fsets data t ?context s = + t.sets data ?context s + + let fgets data t = + t.gets data + end + + + module FieldRO = + struct + let create ?schema ?name ?parse ?print ?default ?update ?help extra = + let fld = + Field.create ?schema ?name ?parse ?print ?default ?update ?help extra + in + fun data -> Field.fget data fld + end +end + +module OASISMessage = struct +(* # 22 "src/oasis/OASISMessage.ml" *) + + + open OASISGettext + open OASISContext + + + let generic_message ~ctxt lvl fmt = + let cond = + if ctxt.quiet then + false + else + match lvl with + | `Debug -> ctxt.debug + | `Info -> ctxt.info + | _ -> true + in + Printf.ksprintf + (fun str -> + if cond then + begin + ctxt.printf lvl str + end) + fmt + + + let debug ~ctxt fmt = + generic_message ~ctxt `Debug fmt + + + let info ~ctxt fmt = + generic_message ~ctxt `Info fmt + + + let warning ~ctxt fmt = + generic_message ~ctxt `Warning fmt + + + let error ~ctxt fmt = + generic_message ~ctxt `Error fmt + +end + +module OASISVersion = struct +(* # 22 "src/oasis/OASISVersion.ml" *) + + + open OASISGettext + + + + + + type s = string + + + type t = string + + + type comparator = + | VGreater of t + | VGreaterEqual of t + | VEqual of t + | VLesser of t + | VLesserEqual of t + | VOr of comparator * comparator + | VAnd of comparator * comparator + + + + (* Range of allowed characters *) + let is_digit c = + '0' <= c && c <= '9' + + + let is_alpha c = + ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') + + + let is_special = + function + | '.' | '+' | '-' | '~' -> true + | _ -> false + + + let rec version_compare v1 v2 = + if v1 <> "" || v2 <> "" then + begin + (* Compare ascii string, using special meaning for version + * related char + *) + let val_ascii c = + if c = '~' then -1 + else if is_digit c then 0 + else if c = '\000' then 0 + else if is_alpha c then Char.code c + else (Char.code c) + 256 + in + + let len1 = String.length v1 in + let len2 = String.length v2 in + + let p = ref 0 in + + (** Compare ascii part *) + let compare_vascii () = + let cmp = ref 0 in + while !cmp = 0 && + !p < len1 && !p < len2 && + not (is_digit v1.[!p] && is_digit v2.[!p]) do + cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); + incr p + done; + if !cmp = 0 && !p < len1 && !p = len2 then + val_ascii v1.[!p] + else if !cmp = 0 && !p = len1 && !p < len2 then + - (val_ascii v2.[!p]) + else + !cmp + in + + (** Compare digit part *) + let compare_digit () = + let extract_int v p = + let start_p = !p in + while !p < String.length v && is_digit v.[!p] do + incr p + done; + let substr = + String.sub v !p ((String.length v) - !p) + in + let res = + match String.sub v start_p (!p - start_p) with + | "" -> 0 + | s -> int_of_string s + in + res, substr + in + let i1, tl1 = extract_int v1 (ref !p) in + let i2, tl2 = extract_int v2 (ref !p) in + i1 - i2, tl1, tl2 + in + + match compare_vascii () with + | 0 -> + begin + match compare_digit () with + | 0, tl1, tl2 -> + if tl1 <> "" && is_digit tl1.[0] then + 1 + else if tl2 <> "" && is_digit tl2.[0] then + -1 + else + version_compare tl1 tl2 + | n, _, _ -> + n + end + | n -> + n + end + else + begin + 0 + end + + + let version_of_string str = str + + + let string_of_version t = t + + + let version_compare_string s1 s2 = + version_compare (version_of_string s1) (version_of_string s2) + + + let chop t = + try + let pos = + String.rindex t '.' + in + String.sub t 0 pos + with Not_found -> + t + + + let rec comparator_apply v op = + match op with + | VGreater cv -> + (version_compare v cv) > 0 + | VGreaterEqual cv -> + (version_compare v cv) >= 0 + | VLesser cv -> + (version_compare v cv) < 0 + | VLesserEqual cv -> + (version_compare v cv) <= 0 + | VEqual cv -> + (version_compare v cv) = 0 + | VOr (op1, op2) -> + (comparator_apply v op1) || (comparator_apply v op2) + | VAnd (op1, op2) -> + (comparator_apply v op1) && (comparator_apply v op2) + + + let rec string_of_comparator = + function + | VGreater v -> "> "^(string_of_version v) + | VEqual v -> "= "^(string_of_version v) + | VLesser v -> "< "^(string_of_version v) + | VGreaterEqual v -> ">= "^(string_of_version v) + | VLesserEqual v -> "<= "^(string_of_version v) + | VOr (c1, c2) -> + (string_of_comparator c1)^" || "^(string_of_comparator c2) + | VAnd (c1, c2) -> + (string_of_comparator c1)^" && "^(string_of_comparator c2) + + + let rec varname_of_comparator = + let concat p v = + OASISUtils.varname_concat + p + (OASISUtils.varname_of_string + (string_of_version v)) + in + function + | VGreater v -> concat "gt" v + | VLesser v -> concat "lt" v + | VEqual v -> concat "eq" v + | VGreaterEqual v -> concat "ge" v + | VLesserEqual v -> concat "le" v + | VOr (c1, c2) -> + (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) + | VAnd (c1, c2) -> + (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) + + + let rec comparator_ge v' = + let cmp v = version_compare v v' >= 0 in + function + | VEqual v + | VGreaterEqual v + | VGreater v -> cmp v + | VLesserEqual _ + | VLesser _ -> false + | VOr (c1, c2) -> comparator_ge v' c1 || comparator_ge v' c2 + | VAnd (c1, c2) -> comparator_ge v' c1 && comparator_ge v' c2 + + +end + +module OASISLicense = struct +(* # 22 "src/oasis/OASISLicense.ml" *) + + + (** License for _oasis fields + @author Sylvain Le Gall + *) + + + + + + type license = string + + + type license_exception = string + + + type license_version = + | Version of OASISVersion.t + | VersionOrLater of OASISVersion.t + | NoVersion + + + + type license_dep_5_unit = + { + license: license; + excption: license_exception option; + version: license_version; + } + + + + type license_dep_5 = + | DEP5Unit of license_dep_5_unit + | DEP5Or of license_dep_5 list + | DEP5And of license_dep_5 list + + + type t = + | DEP5License of license_dep_5 + | OtherLicense of string (* URL *) + + + +end + +module OASISExpr = struct +(* # 22 "src/oasis/OASISExpr.ml" *) + + + + + + open OASISGettext + + + type test = string + + + type flag = string + + + type t = + | EBool of bool + | ENot of t + | EAnd of t * t + | EOr of t * t + | EFlag of flag + | ETest of test * string + + + + type 'a choices = (t * 'a) list + + + let eval var_get t = + let rec eval' = + function + | EBool b -> + b + + | ENot e -> + not (eval' e) + + | EAnd (e1, e2) -> + (eval' e1) && (eval' e2) + + | EOr (e1, e2) -> + (eval' e1) || (eval' e2) + + | EFlag nm -> + let v = + var_get nm + in + assert(v = "true" || v = "false"); + (v = "true") + + | ETest (nm, vl) -> + let v = + var_get nm + in + (v = vl) + in + eval' t + + + let choose ?printer ?name var_get lst = + let rec choose_aux = + function + | (cond, vl) :: tl -> + if eval var_get cond then + vl + else + choose_aux tl + | [] -> + let str_lst = + if lst = [] then + s_ "" + else + String.concat + (s_ ", ") + (List.map + (fun (cond, vl) -> + match printer with + | Some p -> p vl + | None -> s_ "") + lst) + in + match name with + | Some nm -> + failwith + (Printf.sprintf + (f_ "No result for the choice list '%s': %s") + nm str_lst) + | None -> + failwith + (Printf.sprintf + (f_ "No result for a choice list: %s") + str_lst) + in + choose_aux (List.rev lst) + + +end + +module OASISText = struct +(* # 22 "src/oasis/OASISText.ml" *) + + + + type elt = + | Para of string + | Verbatim of string + | BlankLine + + + type t = elt list + +end + +module OASISTypes = struct +(* # 22 "src/oasis/OASISTypes.ml" *) + + + + + + type name = string + type package_name = string + type url = string + type unix_dirname = string + type unix_filename = string + type host_dirname = string + type host_filename = string + type prog = string + type arg = string + type args = string list + type command_line = (prog * arg list) + + + type findlib_name = string + type findlib_full = string + + + type compiled_object = + | Byte + | Native + | Best + + + + type dependency = + | FindlibPackage of findlib_full * OASISVersion.comparator option + | InternalLibrary of name + + + + type tool = + | ExternalTool of name + | InternalExecutable of name + + + + type vcs = + | Darcs + | Git + | Svn + | Cvs + | Hg + | Bzr + | Arch + | Monotone + | OtherVCS of url + + + + type plugin_kind = + [ `Configure + | `Build + | `Doc + | `Test + | `Install + | `Extra + ] + + + type plugin_data_purpose = + [ `Configure + | `Build + | `Install + | `Clean + | `Distclean + | `Install + | `Uninstall + | `Test + | `Doc + | `Extra + | `Other of string + ] + + + type 'a plugin = 'a * name * OASISVersion.t option + + + type all_plugin = plugin_kind plugin + + + type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list + + +(* # 115 "src/oasis/OASISTypes.ml" *) + + + type 'a conditional = 'a OASISExpr.choices + + + type custom = + { + pre_command: (command_line option) conditional; + post_command: (command_line option) conditional; + } + + + + type common_section = + { + cs_name: name; + cs_data: PropList.Data.t; + cs_plugin_data: plugin_data; + } + + + + type build_section = + { + bs_build: bool conditional; + bs_install: bool conditional; + bs_path: unix_dirname; + bs_compiled_object: compiled_object; + bs_build_depends: dependency list; + bs_build_tools: tool list; + bs_c_sources: unix_filename list; + bs_data_files: (unix_filename * unix_filename option) list; + bs_ccopt: args conditional; + bs_cclib: args conditional; + bs_dlllib: args conditional; + bs_dllpath: args conditional; + bs_byteopt: args conditional; + bs_nativeopt: args conditional; + } + + + + type library = + { + lib_modules: string list; + lib_pack: bool; + lib_internal_modules: string list; + lib_findlib_parent: findlib_name option; + lib_findlib_name: findlib_name option; + 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; + } + + + type flag = + { + flag_description: string option; + flag_default: bool conditional; + } + + + type source_repository = + { + src_repo_type: vcs; + src_repo_location: url; + src_repo_browser: url option; + src_repo_module: string option; + src_repo_branch: string option; + src_repo_tag: string option; + src_repo_subdir: unix_filename option; + } + + + type test = + { + test_type: [`Test] plugin; + test_command: command_line conditional; + test_custom: custom; + test_working_directory: unix_filename option; + test_run: bool conditional; + test_tools: tool list; + } + + + type doc_format = + | HTML of unix_filename + | DocText + | PDF + | PostScript + | Info of unix_filename + | DVI + | OtherDoc + + + + type doc = + { + doc_type: [`Doc] plugin; + doc_custom: custom; + doc_build: bool conditional; + doc_install: bool conditional; + doc_install_dir: unix_filename; + doc_title: string; + doc_authors: string list; + doc_abstract: string option; + doc_format: doc_format; + doc_data_files: (unix_filename * unix_filename option) list; + doc_build_tools: tool list; + } + + + 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 + | Test of common_section * test + | Doc of common_section * doc + + + + type section_kind = + [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] + + + type package = + { + oasis_version: OASISVersion.t; + ocaml_version: OASISVersion.comparator option; + findlib_version: OASISVersion.comparator option; + alpha_features: string list; + beta_features: string list; + name: package_name; + version: OASISVersion.t; + license: OASISLicense.t; + license_file: unix_filename option; + copyrights: string list; + maintainers: string list; + authors: string list; + homepage: url option; + synopsis: string; + description: OASISText.t option; + categories: url list; + + conf_type: [`Configure] plugin; + conf_custom: custom; + + build_type: [`Build] plugin; + build_custom: custom; + + install_type: [`Install] plugin; + install_custom: custom; + uninstall_custom: custom; + + clean_custom: custom; + distclean_custom: custom; + + files_ab: unix_filename list; + sections: section list; + plugins: [`Extra] plugin list; + disable_oasis_section: unix_filename list; + schema_data: PropList.Data.t; + plugin_data: plugin_data; + } + + +end + +module OASISFeatures = struct +(* # 22 "src/oasis/OASISFeatures.ml" *) + + open OASISTypes + open OASISUtils + open OASISGettext + open OASISVersion + + module MapPlugin = + Map.Make + (struct + type t = plugin_kind * name + let compare = Pervasives.compare + end) + + module Data = + struct + type t = + { + oasis_version: OASISVersion.t; + plugin_versions: OASISVersion.t option MapPlugin.t; + alpha_features: string list; + beta_features: string list; + } + + let create oasis_version alpha_features beta_features = + { + oasis_version = oasis_version; + plugin_versions = MapPlugin.empty; + alpha_features = alpha_features; + beta_features = beta_features + } + + let of_package pkg = + create + pkg.OASISTypes.oasis_version + pkg.OASISTypes.alpha_features + pkg.OASISTypes.beta_features + + let add_plugin (plugin_kind, plugin_name, plugin_version) t = + {t with + plugin_versions = MapPlugin.add + (plugin_kind, plugin_name) + plugin_version + t.plugin_versions} + + let plugin_version plugin_kind plugin_name t = + MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions + + let to_string t = + Printf.sprintf + "oasis_version: %s; alpha_features: %s; beta_features: %s; \ + plugins_version: %s" + (OASISVersion.string_of_version t.oasis_version) + (String.concat ", " t.alpha_features) + (String.concat ", " t.beta_features) + (String.concat ", " + (MapPlugin.fold + (fun (_, plg) ver_opt acc -> + (plg^ + (match ver_opt with + | Some v -> + " "^(OASISVersion.string_of_version v) + | None -> "")) + :: acc) + t.plugin_versions [])) + end + + type origin = + | Field of string * string + | Section of string + | NoOrigin + + type stage = Alpha | Beta + + + let string_of_stage = + function + | Alpha -> "alpha" + | Beta -> "beta" + + + let field_of_stage = + function + | Alpha -> "AlphaFeatures" + | Beta -> "BetaFeatures" + + type publication = InDev of stage | SinceVersion of OASISVersion.t + + type t = + { + name: string; + plugin: all_plugin option; + publication: publication; + description: unit -> string; + } + + (* TODO: mutex protect this. *) + let all_features = Hashtbl.create 13 + + + let since_version ver_str = SinceVersion (version_of_string ver_str) + let alpha = InDev Alpha + let beta = InDev Beta + + + let to_string t = + Printf.sprintf + "feature: %s; plugin: %s; publication: %s" + t.name + (match t.plugin with + | None -> "" + | Some (_, nm, _) -> nm) + (match t.publication with + | InDev stage -> string_of_stage stage + | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) + + let data_check t data origin = + let no_message = "no message" in + + let check_feature features stage = + let has_feature = List.mem t.name features in + if not has_feature then + match origin with + | Field (fld, where) -> + Some + (Printf.sprintf + (f_ "Field %s in %s is only available when feature %s \ + is in field %s.") + fld where t.name (field_of_stage stage)) + | Section sct -> + Some + (Printf.sprintf + (f_ "Section %s is only available when features %s \ + is in field %s.") + sct t.name (field_of_stage stage)) + | NoOrigin -> + Some no_message + else + None + in + + let version_is_good ~min_version version fmt = + let version_is_good = + OASISVersion.comparator_apply + version (OASISVersion.VGreaterEqual min_version) + in + Printf.ksprintf + (fun str -> + if version_is_good then + None + else + Some str) + fmt + in + + match origin, t.plugin, t.publication with + | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha + | _, _, InDev Beta -> check_feature data.Data.beta_features Beta + | Field(fld, where), None, SinceVersion min_version -> + version_is_good ~min_version data.Data.oasis_version + (f_ "Field %s in %s is only valid since OASIS v%s, update \ + OASISFormat field from '%s' to '%s' after checking \ + OASIS changelog.") + fld where (string_of_version min_version) + (string_of_version data.Data.oasis_version) + (string_of_version min_version) + + | Field(fld, where), Some(plugin_knd, plugin_name, _), + SinceVersion min_version -> + begin + try + let plugin_version_current = + try + match Data.plugin_version plugin_knd plugin_name data with + | Some ver -> ver + | None -> + failwithf + (f_ "Field %s in %s is only valid for the OASIS \ + plugin %s since v%s, but no plugin version is \ + defined in the _oasis file, change '%s' to \ + '%s (%s)' in your _oasis file.") + fld where plugin_name (string_of_version min_version) + plugin_name + plugin_name (string_of_version min_version) + with Not_found -> + failwithf + (f_ "Field %s in %s is only valid when the OASIS plugin %s \ + is defined.") + fld where plugin_name + in + version_is_good ~min_version plugin_version_current + (f_ "Field %s in %s is only valid for the OASIS plugin %s \ + since v%s, update your plugin from '%s (%s)' to \ + '%s (%s)' after checking the plugin's changelog.") + fld where plugin_name (string_of_version min_version) + plugin_name (string_of_version plugin_version_current) + plugin_name (string_of_version min_version) + with Failure msg -> + Some msg + end + + | Section sct, None, SinceVersion min_version -> + version_is_good ~min_version data.Data.oasis_version + (f_ "Section %s is only valid for since OASIS v%s, update \ + OASISFormat field from '%s' to '%s' after checking OASIS \ + changelog.") + sct (string_of_version min_version) + (string_of_version data.Data.oasis_version) + (string_of_version min_version) + + | Section sct, Some(plugin_knd, plugin_name, _), + SinceVersion min_version -> + begin + try + let plugin_version_current = + try + match Data.plugin_version plugin_knd plugin_name data with + | Some ver -> ver + | None -> + failwithf + (f_ "Section %s is only valid for the OASIS \ + plugin %s since v%s, but no plugin version is \ + defined in the _oasis file, change '%s' to \ + '%s (%s)' in your _oasis file.") + sct plugin_name (string_of_version min_version) + plugin_name + plugin_name (string_of_version min_version) + with Not_found -> + failwithf + (f_ "Section %s is only valid when the OASIS plugin %s \ + is defined.") + sct plugin_name + in + version_is_good ~min_version plugin_version_current + (f_ "Section %s is only valid for the OASIS plugin %s \ + since v%s, update your plugin from '%s (%s)' to \ + '%s (%s)' after checking the plugin's changelog.") + sct plugin_name (string_of_version min_version) + plugin_name (string_of_version plugin_version_current) + plugin_name (string_of_version min_version) + with Failure msg -> + Some msg + end + + | NoOrigin, None, SinceVersion min_version -> + version_is_good ~min_version data.Data.oasis_version "%s" no_message + + | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> + begin + try + let plugin_version_current = + match Data.plugin_version plugin_knd plugin_name data with + | Some ver -> ver + | None -> raise Not_found + in + version_is_good ~min_version plugin_version_current + "%s" no_message + with Not_found -> + Some no_message + end + + + let data_assert t data origin = + match data_check t data origin with + | None -> () + | Some str -> failwith str + + + let data_test t data = + match data_check t data NoOrigin with + | None -> true + | Some str -> false + + + let package_test t pkg = + data_test t (Data.of_package pkg) + + + let create ?plugin name publication description = + let () = + if Hashtbl.mem all_features name then + failwithf "Feature '%s' is already declared." name + in + let t = + { + name = name; + plugin = plugin; + publication = publication; + description = description; + } + in + Hashtbl.add all_features name t; + t + + + let get_stage name = + try + (Hashtbl.find all_features name).publication + with Not_found -> + failwithf (f_ "Feature %s doesn't exist.") name + + + let list () = + Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] + + (* + * Real flags. + *) + + + let features = + create "features_fields" + (since_version "0.4") + (fun () -> + s_ "Enable to experiment not yet official features.") + + + let flag_docs = + create "flag_docs" + (since_version "0.3") + (fun () -> + s_ "Building docs require '-docs' flag at configure.") + + + let flag_tests = + create "flag_tests" + (since_version "0.3") + (fun () -> + s_ "Running tests require '-tests' flag at configure.") + + + let pack = + create "pack" + (since_version "0.3") + (fun () -> + s_ "Allow to create packed library.") + + + let section_object = + create "section_object" beta + (fun () -> + s_ "Implement an object section.") + + + let dynrun_for_release = + create "dynrun_for_release" alpha + (fun () -> + s_ "Make '-setup-update dynamic' suitable for releasing project.") + + + let compiled_setup_ml = + create "compiled_setup_ml" alpha + (fun () -> + s_ "It compiles the setup.ml and speed-up actions done with it.") + + let disable_oasis_section = + create "disable_oasis_section" alpha + (fun () -> + s_ "Allows the OASIS section comments and digest to be omitted in \ + generated files.") +end + +module OASISUnixPath = struct +(* # 22 "src/oasis/OASISUnixPath.ml" *) + + + type unix_filename = string + type unix_dirname = string + + + type host_filename = string + type host_dirname = string + + + let current_dir_name = "." + + + let parent_dir_name = ".." + + + let is_current_dir fn = + fn = current_dir_name || fn = "" + + + let concat f1 f2 = + if is_current_dir f1 then + f2 + else + let f1' = + try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 + in + f1'^"/"^f2 + + + let make = + function + | hd :: tl -> + List.fold_left + (fun f p -> concat f p) + hd + tl + | [] -> + invalid_arg "OASISUnixPath.make" + + + let dirname f = + try + String.sub f 0 (String.rindex f '/') + with Not_found -> + current_dir_name + + + let basename f = + try + let pos_start = + (String.rindex f '/') + 1 + in + String.sub f pos_start ((String.length f) - pos_start) + with Not_found -> + f + + + let chop_extension f = + try + let last_dot = + String.rindex f '.' + in + let sub = + String.sub f 0 last_dot + in + try + let last_slash = + String.rindex f '/' + in + if last_slash < last_dot then + sub + else + f + with Not_found -> + sub + + with Not_found -> + f + + + let capitalize_file f = + let dir = dirname f in + let base = basename f in + concat dir (String.capitalize base) + + + let uncapitalize_file f = + let dir = dirname f in + let base = basename f in + concat dir (String.uncapitalize base) + + +end + +module OASISHostPath = struct +(* # 22 "src/oasis/OASISHostPath.ml" *) + + + open Filename + + + module Unix = OASISUnixPath + + + let make = + function + | [] -> + invalid_arg "OASISHostPath.make" + | hd :: tl -> + List.fold_left Filename.concat hd tl + + + let of_unix ufn = + if Sys.os_type = "Unix" then + ufn + else + make + (List.map + (fun p -> + if p = Unix.current_dir_name then + current_dir_name + else if p = Unix.parent_dir_name then + parent_dir_name + else + p) + (OASISString.nsplit ufn '/')) + + +end + +module OASISSection = struct +(* # 22 "src/oasis/OASISSection.ml" *) + + + open OASISTypes + + + let section_kind_common = + function + | Library (cs, _, _) -> + `Library, cs + | Object (cs, _, _) -> + `Object, cs + | Executable (cs, _, _) -> + `Executable, cs + | Flag (cs, _) -> + `Flag, cs + | SrcRepo (cs, _) -> + `SrcRepo, cs + | Test (cs, _) -> + `Test, cs + | Doc (cs, _) -> + `Doc, cs + + + let section_common sct = + snd (section_kind_common sct) + + + 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) + | Test (_, tst) -> Test (cs, tst) + | Doc (_, doc) -> Doc (cs, doc) + + + (** Key used to identify section + *) + let section_id sct = + let k, cs = + section_kind_common sct + in + k, cs.cs_name + + + let string_of_section sct = + let k, nm = + section_id sct + in + (match k with + | `Library -> "library" + | `Object -> "object" + | `Executable -> "executable" + | `Flag -> "flag" + | `SrcRepo -> "src repository" + | `Test -> "test" + | `Doc -> "doc") + ^" "^nm + + + let section_find id scts = + List.find + (fun sct -> id = section_id sct) + scts + + + module CSection = + struct + type t = section + + let id = section_id + + let compare t1 t2 = + compare (id t1) (id t2) + + let equal t1 t2 = + (id t1) = (id t2) + + let hash t = + Hashtbl.hash (id t) + end + + + module MapSection = Map.Make(CSection) + module SetSection = Set.Make(CSection) + + +end + +module OASISBuildSection = struct +(* # 22 "src/oasis/OASISBuildSection.ml" *) + + +end + +module OASISExecutable = struct +(* # 22 "src/oasis/OASISExecutable.ml" *) + + + open OASISTypes + + + let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = + let dir = + OASISUnixPath.concat + bs.bs_path + (OASISUnixPath.dirname exec.exec_main_is) + in + let is_native_exec = + match bs.bs_compiled_object with + | Native -> true + | Best -> is_native () + | Byte -> false + in + + OASISUnixPath.concat + dir + (cs.cs_name^(suffix_program ())), + + if not is_native_exec && + not exec.exec_custom && + bs.bs_c_sources <> [] then + Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) + else + None + + +end + +module OASISLibrary = struct +(* # 22 "src/oasis/OASISLibrary.ml" *) + + + open OASISTypes + open OASISUtils + open OASISGettext + open OASISSection + + + (* Look for a module file, considering capitalization or not. *) + let find_module source_file_exists bs modul = + let possible_base_fn = + List.map + (OASISUnixPath.concat bs.bs_path) + [modul; + OASISUnixPath.uncapitalize_file modul; + OASISUnixPath.capitalize_file modul] + in + (* TODO: we should be able to be able to determine the source for every + * files. Hence we should introduce a Module(source: fn) for the fields + * Modules and InternalModules + *) + List.fold_left + (fun acc base_fn -> + match acc with + | `No_sources _ -> + begin + let file_found = + List.fold_left + (fun acc ext -> + if source_file_exists (base_fn^ext) then + (base_fn^ext) :: acc + else + acc) + [] + [".ml"; ".mli"; ".mll"; ".mly"] + in + match file_found with + | [] -> + acc + | lst -> + `Sources (base_fn, lst) + end + | `Sources _ -> + acc) + (`No_sources possible_base_fn) + possible_base_fn + + + 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 + | `Sources (base_fn, lst) -> + (base_fn, lst) :: acc + | `No_sources _ -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in library %s") + modul cs.cs_name; + acc) + [] + (lib.lib_modules @ lib.lib_internal_modules) + + + let generated_unix_files + ~ctxt + ~is_native + ~has_native_dynlink + ~ext_lib + ~ext_dll + ~source_file_exists + (cs, bs, lib) = + + let find_modules lst ext = + let find_module modul = + match find_module source_file_exists bs modul with + | `Sources (base_fn, [fn]) when ext <> "cmi" + && Filename.check_suffix fn ".mli" -> + None (* No implementation files for pure interface. *) + | `Sources (base_fn, _) -> + Some [base_fn] + | `No_sources lst -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in library %s") + modul cs.cs_name; + Some lst + in + List.fold_left + (fun acc nm -> + match find_module nm with + | None -> acc + | Some base_fns -> + List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) + [] + lst + in + + (* The headers that should be compiled along *) + let headers = + if lib.lib_pack then + [] + else + find_modules + lib.lib_modules + "cmi" + in + + (* The .cmx that be compiled along *) + let cmxs = + let should_be_built = + match bs.bs_compiled_object with + | Native -> true + | Best -> is_native + | Byte -> false + in + if should_be_built then + if lib.lib_pack then + find_modules + [cs.cs_name] + "cmx" + else + find_modules + (lib.lib_modules @ lib.lib_internal_modules) + "cmx" + else + [] + in + + let acc_nopath = + [] + in + + (* Compute what libraries should be built *) + let acc_nopath = + (* Add the packed header file if required *) + let add_pack_header acc = + if lib.lib_pack then + [cs.cs_name^".cmi"] :: acc + else + acc + in + let byte acc = + add_pack_header ([cs.cs_name^".cma"] :: acc) + in + let native acc = + let acc = + add_pack_header + (if has_native_dynlink then + [cs.cs_name^".cmxs"] :: acc + else acc) + in + [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc + in + match bs.bs_compiled_object with + | Native -> + byte (native acc_nopath) + | Best when is_native -> + byte (native acc_nopath) + | Byte | Best -> + byte acc_nopath + in + + (* Add C library to be built *) + let acc_nopath = + if bs.bs_c_sources <> [] then + begin + ["lib"^cs.cs_name^"_stubs"^ext_lib] + :: + ["dll"^cs.cs_name^"_stubs"^ext_dll] + :: + acc_nopath + end + else + acc_nopath + in + + (* All the files generated *) + List.rev_append + (List.rev_map + (List.rev_map + (OASISUnixPath.concat bs.bs_path)) + acc_nopath) + (headers @ cmxs) + + +end + +module OASISObject = struct +(* # 22 "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 +(* # 22 "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 + + + let findlib_mapping pkg = + (* Map from library name to either full findlib name or parts + parent. *) + let fndlb_parts_of_lib_name = + let fndlb_parts cs lib = + let name = + match lib.lib_findlib_name with + | Some nm -> nm + | None -> cs.cs_name + in + let name = + String.concat "." (lib.lib_findlib_containers @ [name]) + in + name + in + List.fold_left + (fun mp -> + function + | Library (cs, _, lib) -> + begin + let lib_name = cs.cs_name in + let fndlb_parts = fndlb_parts cs lib in + if MapString.mem lib_name mp then + failwithf + (f_ "The library name '%s' is used more than once.") + lib_name; + match lib.lib_findlib_parent with + | Some lib_name_parent -> + MapString.add + lib_name + (`Unsolved (lib_name_parent, fndlb_parts)) + mp + | None -> + MapString.add + lib_name + (`Solved fndlb_parts) + 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 + pkg.sections + in + + (* Solve the above graph to be only library name to full findlib name. *) + let fndlb_name_of_lib_name = + let rec solve visited mp lib_name lib_name_child = + if SetString.mem lib_name visited then + failwithf + (f_ "Library '%s' is involved in a cycle \ + with regard to findlib naming.") + lib_name; + let visited = SetString.add lib_name visited in + try + match MapString.find lib_name mp with + | `Solved fndlb_nm -> + fndlb_nm, mp + | `Unsolved (lib_nm_parent, post_fndlb_nm) -> + let pre_fndlb_nm, mp = + solve visited mp lib_nm_parent lib_name + in + let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in + fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp + with Not_found -> + failwithf + (f_ "Library '%s', which is defined as the findlib parent of \ + library '%s', doesn't exist.") + lib_name lib_name_child + in + let mp = + MapString.fold + (fun lib_name status mp -> + match status with + | `Solved _ -> + (* Solved initialy, no need to go further *) + mp + | `Unsolved _ -> + let _, mp = solve SetString.empty mp lib_name "" in + mp) + fndlb_parts_of_lib_name + fndlb_parts_of_lib_name + in + MapString.map + (function + | `Solved fndlb_nm -> fndlb_nm + | `Unsolved _ -> assert false) + mp + in + + (* Convert an internal library name to a findlib name. *) + let findlib_name_of_library_name lib_nm = + try + MapString.find lib_nm fndlb_name_of_lib_name + with Not_found -> + raise (InternalLibraryNotFound lib_nm) + in + + (* Add a library to the tree. + *) + let add sct mp = + let fndlb_fullname = + let cs, _, _ = sct in + let lib_name = cs.cs_name in + findlib_name_of_library_name lib_name + in + let rec add_children nm_lst (children: tree MapString.t) = + match nm_lst with + | (hd :: tl) -> + begin + let node = + try + add_node tl (MapString.find hd children) + with Not_found -> + (* New node *) + new_node tl + in + MapString.add hd node children + end + | [] -> + (* Should not have a nameless library. *) + assert false + and add_node tl node = + if tl = [] then + begin + match node with + | Node (None, children) -> + Node (Some sct, children) + | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> + (* TODO: allow to merge Package, i.e. + * archive(byte) = "foo.cma foo_init.cmo" + *) + let cs, _, _ = sct in + failwithf + (f_ "Library '%s' and '%s' have the same findlib name '%s'") + cs.cs_name cs'.cs_name fndlb_fullname + end + else + begin + match node with + | Leaf data -> + Node (Some data, add_children tl MapString.empty) + | Node (data_opt, children) -> + Node (data_opt, add_children tl children) + end + and new_node = + function + | [] -> + Leaf sct + | hd :: tl -> + Node (None, MapString.add hd (new_node tl) MapString.empty) + in + add_children (OASISString.nsplit fndlb_fullname '.') mp + in + + let rec group_of_tree mp = + MapString.fold + (fun nm node acc -> + let cur = + match node with + | Node (Some (cs, bs, lib), children) -> + Package (nm, cs, bs, lib, group_of_tree children) + | Node (None, children) -> + Container (nm, group_of_tree children) + | Leaf (cs, bs, lib) -> + Package (nm, cs, bs, lib, []) + in + cur :: acc) + mp [] + in + + let group_mp = + List.fold_left + (fun mp -> + function + | Library (cs, bs, lib) -> + add (cs, bs, `Library lib) mp + | Object (cs, bs, obj) -> + add (cs, bs, `Object obj) mp + | _ -> + mp) + MapString.empty + pkg.sections + in + + let groups = + group_of_tree group_mp + in + + let library_name_of_findlib_name = + Lazy.lazy_from_fun + (fun () -> + (* Revert findlib_name_of_library_name. *) + MapString.fold + (fun k v mp -> MapString.add v k mp) + fndlb_name_of_lib_name + MapString.empty) + in + let library_name_of_findlib_name fndlb_nm = + try + MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) + with Not_found -> + raise (FindlibPackageNotFound fndlb_nm) + in + + groups, + findlib_name_of_library_name, + library_name_of_findlib_name + + + let findlib_of_group = + function + | Container (fndlb_nm, _) + | Package (fndlb_nm, _, _, _, _) -> fndlb_nm + + + let root_of_group grp = + let rec root_lib_aux = + (* We do a DFS in the group. *) + function + | Container (_, children) -> + List.fold_left + (fun res grp -> + if res = None then + root_lib_aux grp + else + res) + None + children + | Package (_, cs, bs, lib, _) -> + Some (cs, bs, lib) + in + match root_lib_aux grp with + | Some res -> + res + | None -> + failwithf + (f_ "Unable to determine root library of findlib library '%s'") + (findlib_of_group grp) + + +end + +module OASISFlag = struct +(* # 22 "src/oasis/OASISFlag.ml" *) + + +end + +module OASISPackage = struct +(* # 22 "src/oasis/OASISPackage.ml" *) + + +end + +module OASISSourceRepository = struct +(* # 22 "src/oasis/OASISSourceRepository.ml" *) + + +end + +module OASISTest = struct +(* # 22 "src/oasis/OASISTest.ml" *) + + +end + +module OASISDocument = struct +(* # 22 "src/oasis/OASISDocument.ml" *) + + +end + +module OASISExec = struct +(* # 22 "src/oasis/OASISExec.ml" *) + + + open OASISGettext + open OASISUtils + open OASISMessage + + + (* TODO: I don't like this quote, it is there because $(rm) foo expands to + * 'rm -f' foo... + *) + let run ~ctxt ?f_exit_code ?(quote=true) cmd args = + let cmd = + if quote then + if Sys.os_type = "Win32" then + if String.contains cmd ' ' then + (* Double the 1st double quote... win32... sigh *) + "\""^(Filename.quote cmd) + else + cmd + else + Filename.quote cmd + else + cmd + in + let cmdline = + String.concat " " (cmd :: args) + in + info ~ctxt (f_ "Running command '%s'") cmdline; + match f_exit_code, Sys.command cmdline with + | None, 0 -> () + | None, i -> + failwithf + (f_ "Command '%s' terminated with error code %d") + cmdline i + | Some f, i -> + f i + + + let run_read_output ~ctxt ?f_exit_code cmd args = + let fn = + Filename.temp_file "oasis-" ".txt" + in + try + begin + let () = + run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) + in + let chn = + open_in fn + in + let routput = + ref [] + in + begin + try + while true do + routput := (input_line chn) :: !routput + done + with End_of_file -> + () + end; + close_in chn; + Sys.remove fn; + List.rev !routput + end + with e -> + (try Sys.remove fn with _ -> ()); + raise e + + + let run_read_one_line ~ctxt ?f_exit_code cmd args = + match run_read_output ~ctxt ?f_exit_code cmd args with + | [fst] -> + fst + | lst -> + failwithf + (f_ "Command return unexpected output %S") + (String.concat "\n" lst) +end + +module OASISFileUtil = struct +(* # 22 "src/oasis/OASISFileUtil.ml" *) + + + open OASISGettext + + + let file_exists_case fn = + let dirname = Filename.dirname fn in + let basename = Filename.basename fn in + if Sys.file_exists dirname then + if basename = Filename.current_dir_name then + true + else + List.mem + basename + (Array.to_list (Sys.readdir dirname)) + else + false + + + let find_file ?(case_sensitive=true) paths exts = + + (* Cardinal product of two list *) + let ( * ) lst1 lst2 = + List.flatten + (List.map + (fun a -> + List.map + (fun b -> a, b) + lst2) + lst1) + in + + let rec combined_paths lst = + match lst with + | p1 :: p2 :: tl -> + let acc = + (List.map + (fun (a, b) -> Filename.concat a b) + (p1 * p2)) + in + combined_paths (acc :: tl) + | [e] -> + e + | [] -> + [] + in + + let alternatives = + List.map + (fun (p, e) -> + if String.length e > 0 && e.[0] <> '.' then + p ^ "." ^ e + else + p ^ e) + ((combined_paths paths) * exts) + in + List.find (fun file -> + (if case_sensitive then + file_exists_case file + else + Sys.file_exists file) + && not (Sys.is_directory file) + ) alternatives + + + let which ~ctxt prg = + let path_sep = + match Sys.os_type with + | "Win32" -> + ';' + | _ -> + ':' + in + let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in + let exec_ext = + match Sys.os_type with + | "Win32" -> + "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) + | _ -> + [""] + in + find_file ~case_sensitive:false [path_lst; [prg]] exec_ext + + + (**/**) + let rec fix_dir dn = + (* Windows hack because Sys.file_exists "src\\" = false when + * Sys.file_exists "src" = true + *) + let ln = + String.length dn + in + if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then + fix_dir (String.sub dn 0 (ln - 1)) + else + dn + + + let q = Filename.quote + (**/**) + + + let cp ~ctxt ?(recurse=false) src tgt = + if recurse then + match Sys.os_type with + | "Win32" -> + OASISExec.run ~ctxt + "xcopy" [q src; q tgt; "/E"] + | _ -> + OASISExec.run ~ctxt + "cp" ["-r"; q src; q tgt] + else + OASISExec.run ~ctxt + (match Sys.os_type with + | "Win32" -> "copy" + | _ -> "cp") + [q src; q tgt] + + + let mkdir ~ctxt tgt = + OASISExec.run ~ctxt + (match Sys.os_type with + | "Win32" -> "md" + | _ -> "mkdir") + [q tgt] + + + let rec mkdir_parent ~ctxt f tgt = + let tgt = + fix_dir tgt + in + if Sys.file_exists tgt then + begin + if not (Sys.is_directory tgt) then + OASISUtils.failwithf + (f_ "Cannot create directory '%s', a file of the same name already \ + exists") + tgt + end + else + begin + mkdir_parent ~ctxt f (Filename.dirname tgt); + if not (Sys.file_exists tgt) then + begin + f tgt; + mkdir ~ctxt tgt + end + end + + + let rmdir ~ctxt tgt = + if Sys.readdir tgt = [||] then begin + match Sys.os_type with + | "Win32" -> + OASISExec.run ~ctxt "rd" [q tgt] + | _ -> + OASISExec.run ~ctxt "rm" ["-r"; q tgt] + end else begin + OASISMessage.error ~ctxt + (f_ "Cannot remove directory '%s': not empty.") + tgt + end + + + let glob ~ctxt fn = + let basename = + Filename.basename fn + in + if String.length basename >= 2 && + basename.[0] = '*' && + basename.[1] = '.' then + begin + let ext_len = + (String.length basename) - 2 + in + let ext = + String.sub basename 2 ext_len + in + let dirname = + Filename.dirname fn + in + Array.fold_left + (fun acc fn -> + try + let fn_ext = + String.sub + fn + ((String.length fn) - ext_len) + ext_len + in + if fn_ext = ext then + (Filename.concat dirname fn) :: acc + else + acc + with Invalid_argument _ -> + acc) + [] + (Sys.readdir dirname) + end + else + begin + if file_exists_case fn then + [fn] + else + [] + end +end + + +# 2878 "setup.ml" +module BaseEnvLight = struct +(* # 22 "src/base/BaseEnvLight.ml" *) + + + module MapString = Map.Make(String) + + + type t = string MapString.t + + + let default_filename = + Filename.concat + (Sys.getcwd ()) + "setup.data" + + + let load ?(allow_empty=false) ?(filename=default_filename) () = + if Sys.file_exists filename then + begin + let chn = + open_in_bin filename + in + let st = + Stream.of_channel chn + in + let line = + ref 1 + in + let st_line = + Stream.from + (fun _ -> + try + match Stream.next st with + | '\n' -> incr line; Some '\n' + | c -> Some c + with Stream.Failure -> None) + in + let lexer = + Genlex.make_lexer ["="] st_line + in + let rec read_file mp = + match Stream.npeek 3 lexer with + | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> + Stream.junk lexer; + Stream.junk lexer; + Stream.junk lexer; + read_file (MapString.add nm value mp) + | [] -> + mp + | _ -> + failwith + (Printf.sprintf + "Malformed data file '%s' line %d" + filename !line) + in + let mp = + read_file MapString.empty + in + close_in chn; + mp + end + else if allow_empty then + begin + MapString.empty + end + else + begin + failwith + (Printf.sprintf + "Unable to load environment, the file '%s' doesn't exist." + filename) + end + + + let rec var_expand str env = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) env + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + + + let var_get name env = + var_expand (MapString.find name env) env + + + let var_choose lst env = + OASISExpr.choose + (fun nm -> var_get nm env) + lst +end + + +# 2983 "setup.ml" +module BaseContext = struct +(* # 22 "src/base/BaseContext.ml" *) + + (* TODO: get rid of this module. *) + open OASISContext + + + let args () = fst (fspecs ()) + + + let default = default + +end + +module BaseMessage = struct +(* # 22 "src/base/BaseMessage.ml" *) + + + (** Message to user, overrid for Base + @author Sylvain Le Gall + *) + open OASISMessage + open BaseContext + + + let debug fmt = debug ~ctxt:!default fmt + + + let info fmt = info ~ctxt:!default fmt + + + let warning fmt = warning ~ctxt:!default fmt + + + let error fmt = error ~ctxt:!default fmt + +end + +module BaseEnv = struct +(* # 22 "src/base/BaseEnv.ml" *) + + open OASISGettext + open OASISUtils + open PropList + + + module MapString = BaseEnvLight.MapString + + + type origin_t = + | ODefault + | OGetEnv + | OFileLoad + | OCommandLine + + + type cli_handle_t = + | CLINone + | CLIAuto + | CLIWith + | CLIEnable + | CLIUser of (Arg.key * Arg.spec * Arg.doc) list + + + type definition_t = + { + hide: bool; + dump: bool; + cli: cli_handle_t; + arg_help: string option; + group: string option; + } + + + let schema = + Schema.create "environment" + + + (* Environment data *) + let env = + Data.create () + + + (* Environment data from file *) + let env_from_file = + ref MapString.empty + + + (* Lexer for var *) + let var_lxr = + Genlex.make_lexer [] + + + let rec var_expand str = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + (* TODO: this is a quick hack to allow calling Test.Command + * without defining executable name really. I.e. if there is + * an exec Executable toto, then $(toto) should be replace + * by its real name. It is however useful to have this function + * for other variable that depend on the host and should be + * written better than that. + *) + let st = + var_lxr (Stream.of_string var) + in + match Stream.npeek 3 st with + | [Genlex.Ident "utoh"; Genlex.Ident nm] -> + OASISHostPath.of_unix (var_get nm) + | [Genlex.Ident "utoh"; Genlex.String s] -> + OASISHostPath.of_unix s + | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> + String.escaped (var_get nm) + | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> + String.escaped s + | [Genlex.Ident nm] -> + var_get nm + | _ -> + failwithf + (f_ "Unknown expression '%s' in variable expansion of %s.") + var + str + with + | Unknown_field (_, _) -> + failwithf + (f_ "No variable %s defined when trying to expand %S.") + var + str + | Stream.Error e -> + failwithf + (f_ "Syntax error when parsing '%s' when trying to \ + expand %S: %s") + var + str + e) + str; + Buffer.contents buff + + + and var_get name = + let vl = + try + Schema.get schema env name + with Unknown_field _ as e -> + begin + try + MapString.find name !env_from_file + with Not_found -> + raise e + end + in + var_expand vl + + + let var_choose ?printer ?name lst = + OASISExpr.choose + ?printer + ?name + var_get + lst + + + let var_protect vl = + let buff = + Buffer.create (String.length vl) + in + String.iter + (function + | '$' -> Buffer.add_string buff "\\$" + | c -> Buffer.add_char buff c) + vl; + Buffer.contents buff + + + let var_define + ?(hide=false) + ?(dump=true) + ?short_desc + ?(cli=CLINone) + ?arg_help + ?group + name (* TODO: type constraint on the fact that name must be a valid OCaml + id *) + dflt = + + let default = + [ + OFileLoad, (fun () -> MapString.find name !env_from_file); + ODefault, dflt; + OGetEnv, (fun () -> Sys.getenv name); + ] + in + + let extra = + { + hide = hide; + dump = dump; + cli = cli; + arg_help = arg_help; + group = group; + } + in + + (* Try to find a value that can be defined + *) + let var_get_low lst = + let errors, res = + List.fold_left + (fun (errors, res) (o, v) -> + if res = None then + begin + try + errors, Some (v ()) + with + | Not_found -> + errors, res + | Failure rsn -> + (rsn :: errors), res + | e -> + (Printexc.to_string e) :: errors, res + end + else + errors, res) + ([], None) + (List.sort + (fun (o1, _) (o2, _) -> + Pervasives.compare o2 o1) + lst) + in + match res, errors with + | Some v, _ -> + v + | None, [] -> + raise (Not_set (name, None)) + | None, lst -> + raise (Not_set (name, Some (String.concat (s_ ", ") lst))) + in + + let help = + match short_desc with + | Some fs -> Some fs + | None -> None + in + + let var_get_lst = + FieldRO.create + ~schema + ~name + ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) + ~print:var_get_low + ~default + ~update:(fun ?context x old_x -> x @ old_x) + ?help + extra + in + + fun () -> + var_expand (var_get_low (var_get_lst env)) + + + let var_redefine + ?hide + ?dump + ?short_desc + ?cli + ?arg_help + ?group + name + dflt = + if Schema.mem schema name then + begin + (* TODO: look suspsicious, we want to memorize dflt not dflt () *) + Schema.set schema env ~context:ODefault name (dflt ()); + fun () -> var_get name + end + else + begin + var_define + ?hide + ?dump + ?short_desc + ?cli + ?arg_help + ?group + name + dflt + end + + + let var_ignore (e: unit -> string) = () + + + let print_hidden = + var_define + ~hide:true + ~dump:false + ~cli:CLIAuto + ~arg_help:"Print even non-printable variable. (debug)" + "print_hidden" + (fun () -> "false") + + + let var_all () = + List.rev + (Schema.fold + (fun acc nm def _ -> + if not def.hide || bool_of_string (print_hidden ()) then + nm :: acc + else + acc) + [] + schema) + + + let default_filename = + BaseEnvLight.default_filename + + + let load ?allow_empty ?filename () = + env_from_file := BaseEnvLight.load ?allow_empty ?filename () + + + let unload () = + env_from_file := MapString.empty; + Data.clear env + + + let dump ?(filename=default_filename) () = + let chn = + open_out_bin filename + in + let output nm value = + Printf.fprintf chn "%s=%S\n" nm value + in + let mp_todo = + (* Dump data from schema *) + Schema.fold + (fun mp_todo nm def _ -> + if def.dump then + begin + try + let value = + Schema.get + schema + env + nm + in + output nm value + with Not_set _ -> + () + end; + MapString.remove nm mp_todo) + !env_from_file + schema + in + (* Dump data defined outside of schema *) + MapString.iter output mp_todo; + + (* End of the dump *) + close_out chn + + + let print () = + let printable_vars = + Schema.fold + (fun acc nm def short_descr_opt -> + if not def.hide || bool_of_string (print_hidden ()) then + begin + try + let value = + Schema.get + schema + env + nm + in + let txt = + match short_descr_opt with + | Some s -> s () + | None -> nm + in + (txt, value) :: acc + with Not_set _ -> + acc + end + else + acc) + [] + schema + in + let max_length = + List.fold_left max 0 + (List.rev_map String.length + (List.rev_map fst printable_vars)) + in + let dot_pad str = + String.make ((max_length - (String.length str)) + 3) '.' + in + + Printf.printf "\nConfiguration: \n"; + List.iter + (fun (name, value) -> + Printf.printf "%s: %s %s\n" name (dot_pad name) value) + (List.rev printable_vars); + Printf.printf "\n%!" + + + let args () = + let arg_concat = + OASISUtils.varname_concat ~hyphen:'-' + in + [ + "--override", + Arg.Tuple + ( + let rvr = ref "" + in + let rvl = ref "" + in + [ + Arg.Set_string rvr; + Arg.Set_string rvl; + Arg.Unit + (fun () -> + Schema.set + schema + env + ~context:OCommandLine + !rvr + !rvl) + ] + ), + "var+val Override any configuration variable."; + + ] + @ + List.flatten + (Schema.fold + (fun acc name def short_descr_opt -> + let var_set s = + Schema.set + schema + env + ~context:OCommandLine + name + s + in + + let arg_name = + OASISUtils.varname_of_string ~hyphen:'-' name + in + + let hlp = + match short_descr_opt with + | Some txt -> txt () + | None -> "" + in + + let arg_hlp = + match def.arg_help with + | Some s -> s + | None -> "str" + in + + let default_value = + try + Printf.sprintf + (f_ " [%s]") + (Schema.get + schema + env + name) + with Not_set _ -> + "" + in + + let args = + match def.cli with + | CLINone -> + [] + | CLIAuto -> + [ + arg_concat "--" arg_name, + Arg.String var_set, + Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value + ] + | CLIWith -> + [ + arg_concat "--with-" arg_name, + Arg.String var_set, + Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value + ] + | CLIEnable -> + let dflt = + if default_value = " [true]" then + s_ " [default: enabled]" + else + s_ " [default: disabled]" + in + [ + arg_concat "--enable-" arg_name, + Arg.Unit (fun () -> var_set "true"), + Printf.sprintf (f_ " %s%s") hlp dflt; + + arg_concat "--disable-" arg_name, + Arg.Unit (fun () -> var_set "false"), + Printf.sprintf (f_ " %s%s") hlp dflt + ] + | CLIUser lst -> + lst + in + args :: acc) + [] + schema) +end + +module BaseArgExt = struct +(* # 22 "src/base/BaseArgExt.ml" *) + + + open OASISUtils + open OASISGettext + + + let parse argv args = + (* Simulate command line for Arg *) + let current = + ref 0 + in + + try + Arg.parse_argv + ~current:current + (Array.concat [[|"none"|]; argv]) + (Arg.align args) + (failwithf (f_ "Don't know what to do with arguments: '%s'")) + (s_ "configure options:") + with + | Arg.Help txt -> + print_endline txt; + exit 0 + | Arg.Bad txt -> + prerr_endline txt; + exit 1 +end + +module BaseCheck = struct +(* # 22 "src/base/BaseCheck.ml" *) + + + open BaseEnv + open BaseMessage + open OASISUtils + open OASISGettext + + + let prog_best prg prg_lst = + var_redefine + prg + (fun () -> + let alternate = + List.fold_left + (fun res e -> + match res with + | Some _ -> + res + | None -> + try + Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) + with Not_found -> + None) + None + prg_lst + in + match alternate with + | Some prg -> prg + | None -> raise Not_found) + + + let prog prg = + prog_best prg [prg] + + + let prog_opt prg = + prog_best prg [prg^".opt"; prg] + + + let ocamlfind = + prog "ocamlfind" + + + let version + var_prefix + cmp + fversion + () = + (* Really compare version provided *) + let var = + var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) + in + var_redefine + ~hide:true + var + (fun () -> + let version_str = + match fversion () with + | "[Distributed with OCaml]" -> + begin + try + (var_get "ocaml_version") + with Not_found -> + warning + (f_ "Variable ocaml_version not defined, fallback \ + to default"); + Sys.ocaml_version + end + | res -> + res + in + let version = + OASISVersion.version_of_string version_str + in + if OASISVersion.comparator_apply version cmp then + version_str + else + failwithf + (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") + var_prefix + (OASISVersion.string_of_comparator cmp) + version_str) + () + + + let package_version pkg = + OASISExec.run_read_one_line ~ctxt:!BaseContext.default + (ocamlfind ()) + ["query"; "-format"; "%v"; pkg] + + + let package ?version_comparator pkg () = + let var = + OASISUtils.varname_concat + "pkg_" + (OASISUtils.varname_of_string pkg) + in + let findlib_dir pkg = + let dir = + OASISExec.run_read_one_line ~ctxt:!BaseContext.default + (ocamlfind ()) + ["query"; "-format"; "%d"; pkg] + in + if Sys.file_exists dir && Sys.is_directory dir then + dir + else + failwithf + (f_ "When looking for findlib package %s, \ + directory %s return doesn't exist") + pkg dir + in + let vl = + var_redefine + var + (fun () -> findlib_dir pkg) + () + in + ( + match version_comparator with + | Some ver_cmp -> + ignore + (version + var + ver_cmp + (fun _ -> package_version pkg) + ()) + | None -> + () + ); + vl +end + +module BaseOCamlcConfig = struct +(* # 22 "src/base/BaseOCamlcConfig.ml" *) + + + open BaseEnv + open OASISUtils + open OASISGettext + + + module SMap = Map.Make(String) + + + let ocamlc = + BaseCheck.prog_opt "ocamlc" + + + let ocamlc_config_map = + (* Map name to value for ocamlc -config output + (name ^": "^value) + *) + let rec split_field mp lst = + match lst with + | line :: tl -> + let mp = + try + let pos_semicolon = + String.index line ':' + in + if pos_semicolon > 1 then + ( + let name = + String.sub line 0 pos_semicolon + in + let linelen = + String.length line + in + let value = + if linelen > pos_semicolon + 2 then + String.sub + line + (pos_semicolon + 2) + (linelen - pos_semicolon - 2) + else + "" + in + SMap.add name value mp + ) + else + ( + mp + ) + with Not_found -> + ( + mp + ) + in + split_field mp tl + | [] -> + mp + in + + let cache = + lazy + (var_protect + (Marshal.to_string + (split_field + SMap.empty + (OASISExec.run_read_output + ~ctxt:!BaseContext.default + (ocamlc ()) ["-config"])) + [])) + in + var_redefine + "ocamlc_config_map" + ~hide:true + ~dump:false + (fun () -> + (* TODO: update if ocamlc change !!! *) + Lazy.force cache) + + + let var_define nm = + (* Extract data from ocamlc -config *) + let avlbl_config_get () = + Marshal.from_string + (ocamlc_config_map ()) + 0 + in + let chop_version_suffix s = + try + String.sub s 0 (String.index s '+') + with _ -> + s + in + + let nm_config, value_config = + match nm with + | "ocaml_version" -> + "version", chop_version_suffix + | _ -> nm, (fun x -> x) + in + var_redefine + nm + (fun () -> + try + let map = + avlbl_config_get () + in + let value = + SMap.find nm_config map + in + value_config value + with Not_found -> + failwithf + (f_ "Cannot find field '%s' in '%s -config' output") + nm + (ocamlc ())) + +end + +module BaseStandardVar = struct +(* # 22 "src/base/BaseStandardVar.ml" *) + + + open OASISGettext + open OASISTypes + open OASISExpr + open BaseCheck + open BaseEnv + + + let ocamlfind = BaseCheck.ocamlfind + let ocamlc = BaseOCamlcConfig.ocamlc + let ocamlopt = prog_opt "ocamlopt" + let ocamlbuild = prog "ocamlbuild" + + + (**/**) + let rpkg = + ref None + + + let pkg_get () = + match !rpkg with + | Some pkg -> pkg + | None -> failwith (s_ "OASIS Package is not set") + + + let var_cond = ref [] + + + let var_define_cond ~since_version f dflt = + let holder = ref (fun () -> dflt) in + let since_version = + OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) + in + var_cond := + (fun ver -> + if OASISVersion.comparator_apply ver since_version then + holder := f ()) :: !var_cond; + fun () -> !holder () + + + (**/**) + + + let pkg_name = + var_define + ~short_desc:(fun () -> s_ "Package name") + "pkg_name" + (fun () -> (pkg_get ()).name) + + + let pkg_version = + var_define + ~short_desc:(fun () -> s_ "Package version") + "pkg_version" + (fun () -> + (OASISVersion.string_of_version (pkg_get ()).version)) + + + let c = BaseOCamlcConfig.var_define + + + let os_type = c "os_type" + let system = c "system" + let architecture = c "architecture" + let ccomp_type = c "ccomp_type" + let ocaml_version = c "ocaml_version" + + + (* TODO: Check standard variable presence at runtime *) + + + let standard_library_default = c "standard_library_default" + let standard_library = c "standard_library" + let standard_runtime = c "standard_runtime" + let bytecomp_c_compiler = c "bytecomp_c_compiler" + let native_c_compiler = c "native_c_compiler" + let model = c "model" + let ext_obj = c "ext_obj" + let ext_asm = c "ext_asm" + let ext_lib = c "ext_lib" + let ext_dll = c "ext_dll" + let default_executable_name = c "default_executable_name" + let systhread_supported = c "systhread_supported" + + + let flexlink = + BaseCheck.prog "flexlink" + + + let flexdll_version = + var_define + ~short_desc:(fun () -> "FlexDLL version (Win32)") + "flexdll_version" + (fun () -> + let lst = + OASISExec.run_read_output ~ctxt:!BaseContext.default + (flexlink ()) ["-help"] + in + match lst with + | line :: _ -> + Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) + | [] -> + raise Not_found) + + + (**/**) + let p name hlp dflt = + var_define + ~short_desc:hlp + ~cli:CLIAuto + ~arg_help:"dir" + name + dflt + + + let (/) a b = + if os_type () = Sys.os_type then + Filename.concat a b + else if os_type () = "Unix" then + OASISUnixPath.concat a b + else + OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") + (os_type ()) + (**/**) + + + let prefix = + p "prefix" + (fun () -> s_ "Install architecture-independent files dir") + (fun () -> + match os_type () with + | "Win32" -> + let program_files = + Sys.getenv "PROGRAMFILES" + in + program_files/(pkg_name ()) + | _ -> + "/usr/local") + + + let exec_prefix = + p "exec_prefix" + (fun () -> s_ "Install architecture-dependent files in dir") + (fun () -> "$prefix") + + + let bindir = + p "bindir" + (fun () -> s_ "User executables") + (fun () -> "$exec_prefix"/"bin") + + + let sbindir = + p "sbindir" + (fun () -> s_ "System admin executables") + (fun () -> "$exec_prefix"/"sbin") + + + let libexecdir = + p "libexecdir" + (fun () -> s_ "Program executables") + (fun () -> "$exec_prefix"/"libexec") + + + let sysconfdir = + p "sysconfdir" + (fun () -> s_ "Read-only single-machine data") + (fun () -> "$prefix"/"etc") + + + let sharedstatedir = + p "sharedstatedir" + (fun () -> s_ "Modifiable architecture-independent data") + (fun () -> "$prefix"/"com") + + + let localstatedir = + p "localstatedir" + (fun () -> s_ "Modifiable single-machine data") + (fun () -> "$prefix"/"var") + + + let libdir = + p "libdir" + (fun () -> s_ "Object code libraries") + (fun () -> "$exec_prefix"/"lib") + + + let datarootdir = + p "datarootdir" + (fun () -> s_ "Read-only arch-independent data root") + (fun () -> "$prefix"/"share") + + + let datadir = + p "datadir" + (fun () -> s_ "Read-only architecture-independent data") + (fun () -> "$datarootdir") + + + let infodir = + p "infodir" + (fun () -> s_ "Info documentation") + (fun () -> "$datarootdir"/"info") + + + let localedir = + p "localedir" + (fun () -> s_ "Locale-dependent data") + (fun () -> "$datarootdir"/"locale") + + + let mandir = + p "mandir" + (fun () -> s_ "Man documentation") + (fun () -> "$datarootdir"/"man") + + + let docdir = + p "docdir" + (fun () -> s_ "Documentation root") + (fun () -> "$datarootdir"/"doc"/"$pkg_name") + + + let htmldir = + p "htmldir" + (fun () -> s_ "HTML documentation") + (fun () -> "$docdir") + + + let dvidir = + p "dvidir" + (fun () -> s_ "DVI documentation") + (fun () -> "$docdir") + + + let pdfdir = + p "pdfdir" + (fun () -> s_ "PDF documentation") + (fun () -> "$docdir") + + + let psdir = + p "psdir" + (fun () -> s_ "PS documentation") + (fun () -> "$docdir") + + + let destdir = + p "destdir" + (fun () -> s_ "Prepend a path when installing package") + (fun () -> + raise + (PropList.Not_set + ("destdir", + Some (s_ "undefined by construct")))) + + + let findlib_version = + var_define + "findlib_version" + (fun () -> + BaseCheck.package_version "findlib") + + + let is_native = + var_define + "is_native" + (fun () -> + try + let _s: string = + ocamlopt () + in + "true" + with PropList.Not_set _ -> + let _s: string = + ocamlc () + in + "false") + + + let ext_program = + var_define + "suffix_program" + (fun () -> + match os_type () with + | "Win32" | "Cygwin" -> ".exe" + | _ -> "") + + + let rm = + var_define + ~short_desc:(fun () -> s_ "Remove a file.") + "rm" + (fun () -> + match os_type () with + | "Win32" -> "del" + | _ -> "rm -f") + + + let rmdir = + var_define + ~short_desc:(fun () -> s_ "Remove a directory.") + "rmdir" + (fun () -> + match os_type () with + | "Win32" -> "rd" + | _ -> "rm -rf") + + + let debug = + var_define + ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") + ~cli:CLIEnable + "debug" + (fun () -> "true") + + + let profile = + var_define + ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") + ~cli:CLIEnable + "profile" + (fun () -> "false") + + + let tests = + var_define_cond ~since_version:"0.3" + (fun () -> + var_define + ~short_desc:(fun () -> + s_ "Compile tests executable and library and run them") + ~cli:CLIEnable + "tests" + (fun () -> "false")) + "true" + + + let docs = + var_define_cond ~since_version:"0.3" + (fun () -> + var_define + ~short_desc:(fun () -> s_ "Create documentations") + ~cli:CLIEnable + "docs" + (fun () -> "true")) + "true" + + + let native_dynlink = + var_define + ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") + ~cli:CLINone + "native_dynlink" + (fun () -> + let res = + let ocaml_lt_312 () = + OASISVersion.comparator_apply + (OASISVersion.version_of_string (ocaml_version ())) + (OASISVersion.VLesser + (OASISVersion.version_of_string "3.12.0")) + in + let flexdll_lt_030 () = + OASISVersion.comparator_apply + (OASISVersion.version_of_string (flexdll_version ())) + (OASISVersion.VLesser + (OASISVersion.version_of_string "0.30")) + in + let has_native_dynlink = + let ocamlfind = ocamlfind () in + try + let fn = + OASISExec.run_read_one_line + ~ctxt:!BaseContext.default + ocamlfind + ["query"; "-predicates"; "native"; "dynlink"; + "-format"; "%d/%a"] + in + Sys.file_exists fn + with _ -> + false + in + if not has_native_dynlink then + false + else if ocaml_lt_312 () then + false + else if (os_type () = "Win32" || os_type () = "Cygwin") + && flexdll_lt_030 () then + begin + BaseMessage.warning + (f_ ".cmxs generation disabled because FlexDLL needs to be \ + at least 0.30. Please upgrade FlexDLL from %s to 0.30.") + (flexdll_version ()); + false + end + else + true + in + string_of_bool res) + + + let init pkg = + rpkg := Some pkg; + List.iter (fun f -> f pkg.oasis_version) !var_cond + +end + +module BaseFileAB = struct +(* # 22 "src/base/BaseFileAB.ml" *) + + + open BaseEnv + open OASISGettext + open BaseMessage + + + let to_filename fn = + let fn = + OASISHostPath.of_unix fn + in + if not (Filename.check_suffix fn ".ab") then + warning + (f_ "File '%s' doesn't have '.ab' extension") + fn; + Filename.chop_extension fn + + + let replace fn_lst = + let buff = + Buffer.create 13 + in + List.iter + (fun fn -> + let fn = + OASISHostPath.of_unix fn + in + let chn_in = + open_in fn + in + let chn_out = + open_out (to_filename fn) + in + ( + try + while true do + Buffer.add_string buff (var_expand (input_line chn_in)); + Buffer.add_char buff '\n' + done + with End_of_file -> + () + ); + Buffer.output_buffer chn_out buff; + Buffer.clear buff; + close_in chn_in; + close_out chn_out) + fn_lst +end + +module BaseLog = struct +(* # 22 "src/base/BaseLog.ml" *) + + + open OASISUtils + + + let default_filename = + Filename.concat + (Filename.dirname BaseEnv.default_filename) + "setup.log" + + + module SetTupleString = + Set.Make + (struct + type t = string * string + let compare (s11, s12) (s21, s22) = + match String.compare s11 s21 with + | 0 -> String.compare s12 s22 + | n -> n + end) + + + let load () = + if Sys.file_exists default_filename then + begin + let chn = + open_in default_filename + in + let scbuf = + Scanf.Scanning.from_file default_filename + in + let rec read_aux (st, lst) = + if not (Scanf.Scanning.end_of_input scbuf) then + begin + let acc = + try + Scanf.bscanf scbuf "%S %S\n" + (fun e d -> + let t = + e, d + in + if SetTupleString.mem t st then + st, lst + else + SetTupleString.add t st, + t :: lst) + with Scanf.Scan_failure _ -> + failwith + (Scanf.bscanf scbuf + "%l" + (fun line -> + Printf.sprintf + "Malformed log file '%s' at line %d" + default_filename + line)) + in + read_aux acc + end + else + begin + close_in chn; + List.rev lst + end + in + read_aux (SetTupleString.empty, []) + end + else + begin + [] + end + + + let register event data = + let chn_out = + open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename + in + Printf.fprintf chn_out "%S %S\n" event data; + close_out chn_out + + + let unregister event data = + if Sys.file_exists default_filename then + begin + let lst = + load () + in + let chn_out = + open_out default_filename + in + let write_something = + ref false + in + List.iter + (fun (e, d) -> + if e <> event || d <> data then + begin + write_something := true; + Printf.fprintf chn_out "%S %S\n" e d + end) + lst; + close_out chn_out; + if not !write_something then + Sys.remove default_filename + end + + + let filter events = + let st_events = + List.fold_left + (fun st e -> + SetString.add e st) + SetString.empty + events + in + List.filter + (fun (e, _) -> SetString.mem e st_events) + (load ()) + + + let exists event data = + List.exists + (fun v -> (event, data) = v) + (load ()) +end + +module BaseBuilt = struct +(* # 22 "src/base/BaseBuilt.ml" *) + + + open OASISTypes + open OASISGettext + open BaseStandardVar + open BaseMessage + + + type t = + | BExec (* Executable *) + | BExecLib (* Library coming with executable *) + | BLib (* Library *) + | BObj (* Library *) + | BDoc (* Document *) + + + let to_log_event_file t nm = + "built_"^ + (match t with + | BExec -> "exec" + | BExecLib -> "exec_lib" + | BLib -> "lib" + | BObj -> "obj" + | BDoc -> "doc")^ + "_"^nm + + + let to_log_event_done t nm = + "is_"^(to_log_event_file t nm) + + + let register t nm lst = + BaseLog.register + (to_log_event_done t nm) + "true"; + List.iter + (fun alt -> + let registered = + List.fold_left + (fun registered fn -> + if OASISFileUtil.file_exists_case fn then + begin + BaseLog.register + (to_log_event_file t nm) + (if Filename.is_relative fn then + Filename.concat (Sys.getcwd ()) fn + else + fn); + true + end + else + registered) + false + alt + in + if not registered then + warning + (f_ "Cannot find an existing alternative files among: %s") + (String.concat (s_ ", ") alt)) + lst + + + let unregister t nm = + List.iter + (fun (e, d) -> + BaseLog.unregister e d) + (BaseLog.filter + [to_log_event_file t nm; + to_log_event_done t nm]) + + + let fold t nm f acc = + List.fold_left + (fun acc (_, fn) -> + if OASISFileUtil.file_exists_case fn then + begin + f acc fn + end + else + begin + warning + (f_ "File '%s' has been marked as built \ + for %s but doesn't exist") + fn + (Printf.sprintf + (match t with + | BExec | BExecLib -> + (f_ "executable %s") + | BLib -> + (f_ "library %s") + | BObj -> + (f_ "object %s") + | BDoc -> + (f_ "documentation %s")) + nm); + acc + end) + acc + (BaseLog.filter + [to_log_event_file t nm]) + + + let is_built t nm = + List.fold_left + (fun is_built (_, d) -> + (try + bool_of_string d + with _ -> + false)) + false + (BaseLog.filter + [to_log_event_done t nm]) + + + let of_executable ffn (cs, bs, exec) = + let unix_exec_is, unix_dll_opt = + OASISExecutable.unix_exec_is + (cs, bs, exec) + (fun () -> + bool_of_string + (is_native ())) + ext_dll + ext_program + in + let evs = + (BExec, cs.cs_name, [[ffn unix_exec_is]]) + :: + (match unix_dll_opt with + | Some fn -> + [BExecLib, cs.cs_name, [[ffn fn]]] + | None -> + []) + in + evs, + unix_exec_is, + unix_dll_opt + + + let of_library ffn (cs, bs, lib) = + let unix_lst = + OASISLibrary.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 ())) + ~has_native_dynlink:(bool_of_string (native_dynlink ())) + ~ext_lib:(ext_lib ()) + ~ext_dll:(ext_dll ()) + (cs, bs, lib) + in + let evs = + [BLib, + cs.cs_name, + List.map (List.map ffn) unix_lst] + 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 +(* # 22 "src/base/BaseCustom.ml" *) + + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISGettext + + + let run cmd args extra_args = + OASISExec.run ~ctxt:!BaseContext.default ~quote:false + (var_expand cmd) + (List.map + var_expand + (args @ (Array.to_list extra_args))) + + + let hook ?(failsafe=false) cstm f e = + let optional_command lst = + let printer = + function + | Some (cmd, args) -> String.concat " " (cmd :: args) + | None -> s_ "No command" + in + match + var_choose + ~name:(s_ "Pre/Post Command") + ~printer + lst with + | Some (cmd, args) -> + begin + try + run cmd args [||] + with e when failsafe -> + warning + (f_ "Command '%s' fail with error: %s") + (String.concat " " (cmd :: args)) + (match e with + | Failure msg -> msg + | e -> Printexc.to_string e) + end + | None -> + () + in + let res = + optional_command cstm.pre_command; + f e + in + optional_command cstm.post_command; + res +end + +module BaseDynVar = struct +(* # 22 "src/base/BaseDynVar.ml" *) + + + open OASISTypes + open OASISGettext + open BaseEnv + open BaseBuilt + + + let init pkg = + (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) + (* TODO: provide compile option for library libary_byte_args_VARNAME... *) + List.iter + (function + | Executable (cs, bs, exec) -> + if var_choose bs.bs_build then + var_ignore + (var_redefine + (* We don't save this variable *) + ~dump:false + ~short_desc:(fun () -> + Printf.sprintf + (f_ "Filename of executable '%s'") + cs.cs_name) + (OASISUtils.varname_of_string cs.cs_name) + (fun () -> + let fn_opt = + fold + BExec cs.cs_name + (fun _ fn -> Some fn) + None + in + match fn_opt with + | Some fn -> fn + | None -> + raise + (PropList.Not_set + (cs.cs_name, + Some (Printf.sprintf + (f_ "Executable '%s' not yet built.") + cs.cs_name))))) + + | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> + ()) + pkg.sections +end + +module BaseTest = struct +(* # 22 "src/base/BaseTest.ml" *) + + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISExpr + open OASISGettext + + + let test lst pkg extra_args = + + let one_test (failure, n) (test_plugin, cs, test) = + if var_choose + ~name:(Printf.sprintf + (f_ "test %s run") + cs.cs_name) + ~printer:string_of_bool + test.test_run then + begin + let () = + info (f_ "Running test '%s'") cs.cs_name + in + let back_cwd = + match test.test_working_directory with + | Some dir -> + let cwd = + Sys.getcwd () + in + let chdir d = + info (f_ "Changing directory to '%s'") d; + Sys.chdir d + in + chdir dir; + fun () -> chdir cwd + + | None -> + fun () -> () + in + try + let failure_percent = + BaseCustom.hook + test.test_custom + (test_plugin pkg (cs, test)) + extra_args + in + back_cwd (); + (failure_percent +. failure, n + 1) + with e -> + begin + back_cwd (); + raise e + end + end + else + begin + info (f_ "Skipping test '%s'") cs.cs_name; + (failure, n) + end + in + let failed, n = + List.fold_left + one_test + (0.0, 0) + lst + in + let failure_percent = + if n = 0 then + 0.0 + else + failed /. (float_of_int n) + in + let msg = + Printf.sprintf + (f_ "Tests had a %.2f%% failure rate") + (100. *. failure_percent) + in + if failure_percent > 0.0 then + failwith msg + else + info "%s" msg; + + (* Possible explanation why the tests where not run. *) + if OASISFeatures.package_test OASISFeatures.flag_tests pkg && + not (bool_of_string (BaseStandardVar.tests ())) && + lst <> [] then + BaseMessage.warning + "Tests are turned off, consider enabling with \ + 'ocaml setup.ml -configure --enable-tests'" +end + +module BaseDoc = struct +(* # 22 "src/base/BaseDoc.ml" *) + + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISGettext + + + let doc lst pkg extra_args = + + let one_doc (doc_plugin, cs, doc) = + if var_choose + ~name:(Printf.sprintf + (f_ "documentation %s build") + cs.cs_name) + ~printer:string_of_bool + doc.doc_build then + begin + info (f_ "Building documentation '%s'") cs.cs_name; + BaseCustom.hook + doc.doc_custom + (doc_plugin pkg (cs, doc)) + extra_args + end + in + List.iter one_doc lst; + + if OASISFeatures.package_test OASISFeatures.flag_docs pkg && + not (bool_of_string (BaseStandardVar.docs ())) && + lst <> [] then + BaseMessage.warning + "Docs are turned off, consider enabling with \ + 'ocaml setup.ml -configure --enable-docs'" +end + +module BaseSetup = struct +(* # 22 "src/base/BaseSetup.ml" *) + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISSection + open OASISGettext + open OASISUtils + + + type std_args_fun = + package -> string array -> unit + + + type ('a, 'b) section_args_fun = + name * (package -> (common_section * 'a) -> string array -> 'b) + + + type t = + { + configure: std_args_fun; + build: std_args_fun; + doc: ((doc, unit) section_args_fun) list; + test: ((test, float) section_args_fun) list; + install: std_args_fun; + uninstall: std_args_fun; + clean: std_args_fun list; + clean_doc: (doc, unit) section_args_fun list; + clean_test: (test, unit) section_args_fun list; + distclean: std_args_fun list; + distclean_doc: (doc, unit) section_args_fun list; + distclean_test: (test, unit) section_args_fun list; + package: package; + oasis_fn: string option; + oasis_version: string; + oasis_digest: Digest.t option; + oasis_exec: string option; + oasis_setup_args: string list; + setup_update: bool; + } + + + (* Associate a plugin function with data from package *) + let join_plugin_sections filter_map lst = + List.rev + (List.fold_left + (fun acc sct -> + match filter_map sct with + | Some e -> + e :: acc + | None -> + acc) + [] + lst) + + + (* Search for plugin data associated with a section name *) + let lookup_plugin_section plugin action nm lst = + try + List.assoc nm lst + with Not_found -> + failwithf + (f_ "Cannot find plugin %s matching section %s for %s action") + plugin + nm + action + + + let configure t args = + (* Run configure *) + BaseCustom.hook + t.package.conf_custom + (fun () -> + (* Reload if preconf has changed it *) + begin + try + unload (); + load (); + with _ -> + () + end; + + (* Run plugin's configure *) + t.configure t.package args; + + (* Dump to allow postconf to change it *) + dump ()) + (); + + (* Reload environment *) + unload (); + load (); + + (* Save environment *) + print (); + + (* Replace data in file *) + BaseFileAB.replace t.package.files_ab + + + let build t args = + BaseCustom.hook + t.package.build_custom + (t.build t.package) + args + + + let doc t args = + BaseDoc.doc + (join_plugin_sections + (function + | Doc (cs, e) -> + Some + (lookup_plugin_section + "documentation" + (s_ "build") + cs.cs_name + t.doc, + cs, + e) + | _ -> + None) + t.package.sections) + t.package + args + + + let test t args = + BaseTest.test + (join_plugin_sections + (function + | Test (cs, e) -> + Some + (lookup_plugin_section + "test" + (s_ "run") + cs.cs_name + t.test, + cs, + e) + | _ -> + None) + t.package.sections) + t.package + args + + + let all t args = + let rno_doc = + ref false + in + let rno_test = + ref false + in + let arg_rest = + ref [] + in + Arg.parse_argv + ~current:(ref 0) + (Array.of_list + ((Sys.executable_name^" all") :: + (Array.to_list args))) + [ + "-no-doc", + Arg.Set rno_doc, + s_ "Don't run doc target"; + + "-no-test", + Arg.Set rno_test, + s_ "Don't run test target"; + + "--", + Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), + s_ "All arguments for configure."; + ] + (failwithf (f_ "Don't know what to do with '%s'")) + ""; + + info "Running configure step"; + configure t (Array.of_list (List.rev !arg_rest)); + + info "Running build step"; + build t [||]; + + (* Load setup.log dynamic variables *) + BaseDynVar.init t.package; + + if not !rno_doc then + begin + info "Running doc step"; + doc t [||]; + end + else + begin + info "Skipping doc step" + end; + + if not !rno_test then + begin + info "Running test step"; + test t [||] + end + else + begin + info "Skipping test step" + end + + + let install t args = + BaseCustom.hook + t.package.install_custom + (t.install t.package) + args + + + let uninstall t args = + BaseCustom.hook + t.package.uninstall_custom + (t.uninstall t.package) + args + + + let reinstall t args = + uninstall t args; + install t args + + + let clean, distclean = + let failsafe f a = + try + f a + with e -> + warning + (f_ "Action fail with error: %s") + (match e with + | Failure msg -> msg + | e -> Printexc.to_string e) + in + + let generic_clean t cstm mains docs tests args = + BaseCustom.hook + ~failsafe:true + cstm + (fun () -> + (* Clean section *) + List.iter + (function + | Test (cs, test) -> + let f = + try + List.assoc cs.cs_name tests + with Not_found -> + fun _ _ _ -> () + in + failsafe + (f t.package (cs, test)) + args + | Doc (cs, doc) -> + let f = + try + List.assoc cs.cs_name docs + with Not_found -> + fun _ _ _ -> () + in + failsafe + (f t.package (cs, doc)) + args + | Library _ + | Object _ + | Executable _ + | Flag _ + | SrcRepo _ -> + ()) + t.package.sections; + (* Clean whole package *) + List.iter + (fun f -> + failsafe + (f t.package) + args) + mains) + () + in + + let clean t args = + generic_clean + t + t.package.clean_custom + t.clean + t.clean_doc + t.clean_test + args + in + + let distclean t args = + (* Call clean *) + clean t args; + + (* Call distclean code *) + generic_clean + t + t.package.distclean_custom + t.distclean + t.distclean_doc + t.distclean_test + args; + + (* Remove generated file *) + List.iter + (fun fn -> + if Sys.file_exists fn then + begin + info (f_ "Remove '%s'") fn; + Sys.remove fn + end) + (BaseEnv.default_filename + :: + BaseLog.default_filename + :: + (List.rev_map BaseFileAB.to_filename t.package.files_ab)) + in + + clean, distclean + + + let version t _ = + print_endline t.oasis_version + + + let update_setup_ml, no_update_setup_ml_cli = + let b = ref true in + b, + ("-no-update-setup-ml", + Arg.Clear b, + s_ " Don't try to update setup.ml, even if _oasis has changed.") + + + let default_oasis_fn = "_oasis" + + + let update_setup_ml t = + let oasis_fn = + match t.oasis_fn with + | Some fn -> fn + | None -> default_oasis_fn + in + let oasis_exec = + match t.oasis_exec with + | Some fn -> fn + | None -> "oasis" + in + let ocaml = + Sys.executable_name + in + let setup_ml, args = + match Array.to_list Sys.argv with + | setup_ml :: args -> + setup_ml, args + | [] -> + failwith + (s_ "Expecting non-empty command line arguments.") + in + let ocaml, setup_ml = + if Sys.executable_name = Sys.argv.(0) then + (* We are not running in standard mode, probably the script + * is precompiled. + *) + "ocaml", "setup.ml" + else + ocaml, setup_ml + in + let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in + let do_update () = + let oasis_exec_version = + OASISExec.run_read_one_line + ~ctxt:!BaseContext.default + ~f_exit_code: + (function + | 0 -> + () + | 1 -> + failwithf + (f_ "Executable '%s' is probably an old version \ + of oasis (< 0.3.0), please update to version \ + v%s.") + oasis_exec t.oasis_version + | 127 -> + failwithf + (f_ "Cannot find executable '%s', please install \ + oasis v%s.") + oasis_exec t.oasis_version + | n -> + failwithf + (f_ "Command '%s version' exited with code %d.") + oasis_exec n) + oasis_exec ["version"] + in + if OASISVersion.comparator_apply + (OASISVersion.version_of_string oasis_exec_version) + (OASISVersion.VGreaterEqual + (OASISVersion.version_of_string t.oasis_version)) then + begin + (* We have a version >= for the executable oasis, proceed with + * update. + *) + (* TODO: delegate this check to 'oasis setup'. *) + if Sys.os_type = "Win32" then + failwithf + (f_ "It is not possible to update the running script \ + setup.ml on Windows. Please update setup.ml by \ + running '%s'.") + (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) + else + begin + OASISExec.run + ~ctxt:!BaseContext.default + ~f_exit_code: + (function + | 0 -> + () + | n -> + failwithf + (f_ "Unable to update setup.ml using '%s', \ + please fix the problem and retry.") + oasis_exec) + oasis_exec ("setup" :: t.oasis_setup_args); + OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) + end + end + else + failwithf + (f_ "The version of '%s' (v%s) doesn't match the version of \ + oasis used to generate the %s file. Please install at \ + least oasis v%s.") + oasis_exec oasis_exec_version setup_ml t.oasis_version + in + + if !update_setup_ml then + begin + try + match t.oasis_digest with + | Some dgst -> + if Sys.file_exists oasis_fn && + dgst <> Digest.file default_oasis_fn then + begin + do_update (); + true + end + else + false + | None -> + false + with e -> + error + (f_ "Error when updating setup.ml. If you want to avoid this error, \ + you can bypass the update of %s by running '%s %s %s %s'") + setup_ml ocaml setup_ml no_update_setup_ml_cli + (String.concat " " args); + raise e + end + else + false + + + let setup t = + let catch_exn = + ref true + in + try + let act_ref = + ref (fun _ -> + failwithf + (f_ "No action defined, run '%s %s -help'") + Sys.executable_name + Sys.argv.(0)) + + in + let extra_args_ref = + ref [] + in + let allow_empty_env_ref = + ref false + in + let arg_handle ?(allow_empty_env=false) act = + Arg.Tuple + [ + Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); + + Arg.Unit + (fun () -> + allow_empty_env_ref := allow_empty_env; + act_ref := act); + ] + in + + Arg.parse + (Arg.align + ([ + "-configure", + arg_handle ~allow_empty_env:true configure, + s_ "[options*] Configure the whole build process."; + + "-build", + arg_handle build, + s_ "[options*] Build executables and libraries."; + + "-doc", + arg_handle doc, + s_ "[options*] Build documents."; + + "-test", + arg_handle test, + s_ "[options*] Run tests."; + + "-all", + arg_handle ~allow_empty_env:true all, + s_ "[options*] Run configure, build, doc and test targets."; + + "-install", + arg_handle install, + s_ "[options*] Install libraries, data, executables \ + and documents."; + + "-uninstall", + arg_handle uninstall, + s_ "[options*] Uninstall libraries, data, executables \ + and documents."; + + "-reinstall", + arg_handle reinstall, + s_ "[options*] Uninstall and install libraries, data, \ + executables and documents."; + + "-clean", + arg_handle ~allow_empty_env:true clean, + s_ "[options*] Clean files generated by a build."; + + "-distclean", + arg_handle ~allow_empty_env:true distclean, + s_ "[options*] Clean files generated by a build and configure."; + + "-version", + arg_handle ~allow_empty_env:true version, + s_ " Display version of OASIS used to generate this setup.ml."; + + "-no-catch-exn", + Arg.Clear catch_exn, + s_ " Don't catch exception, useful for debugging."; + ] + @ + (if t.setup_update then + [no_update_setup_ml_cli] + else + []) + @ (BaseContext.args ()))) + (failwithf (f_ "Don't know what to do with '%s'")) + (s_ "Setup and run build process current package\n"); + + (* Build initial environment *) + load ~allow_empty:!allow_empty_env_ref (); + + (** Initialize flags *) + List.iter + (function + | Flag (cs, {flag_description = hlp; + flag_default = choices}) -> + begin + let apply ?short_desc () = + var_ignore + (var_define + ~cli:CLIEnable + ?short_desc + (OASISUtils.varname_of_string cs.cs_name) + (fun () -> + string_of_bool + (var_choose + ~name:(Printf.sprintf + (f_ "default value of flag %s") + cs.cs_name) + ~printer:string_of_bool + choices))) + in + match hlp with + | Some hlp -> + apply ~short_desc:(fun () -> hlp) () + | None -> + apply () + end + | _ -> + ()) + t.package.sections; + + BaseStandardVar.init t.package; + + BaseDynVar.init t.package; + + if t.setup_update && update_setup_ml t then + () + else + !act_ref t (Array.of_list (List.rev !extra_args_ref)) + + with e when !catch_exn -> + error "%s" (Printexc.to_string e); + exit 1 + + +end + + +# 5394 "setup.ml" +module InternalConfigurePlugin = struct +(* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) + + + (** Configure using internal scheme + @author Sylvain Le Gall + *) + + + open BaseEnv + open OASISTypes + open OASISUtils + open OASISGettext + open BaseMessage + + + (** Configure build using provided series of check to be done + * and then output corresponding file. + *) + let configure pkg argv = + let var_ignore_eval var = let _s: string = var () in () in + let errors = ref SetString.empty in + let buff = Buffer.create 13 in + + let add_errors fmt = + Printf.kbprintf + (fun b -> + errors := SetString.add (Buffer.contents b) !errors; + Buffer.clear b) + buff + fmt + in + + let warn_exception e = + warning "%s" (Printexc.to_string e) + in + + (* Check tools *) + let check_tools lst = + List.iter + (function + | ExternalTool tool -> + begin + try + var_ignore_eval (BaseCheck.prog tool) + with e -> + warn_exception e; + add_errors (f_ "Cannot find external tool '%s'") tool + end + | InternalExecutable nm1 -> + (* Check that matching tool is built *) + List.iter + (function + | Executable ({cs_name = nm2}, + {bs_build = build}, + _) when nm1 = nm2 -> + if not (var_choose build) then + add_errors + (f_ "Cannot find buildable internal executable \ + '%s' when checking build depends") + nm1 + | _ -> + ()) + pkg.sections) + lst + in + + let build_checks sct bs = + if var_choose bs.bs_build then + begin + if bs.bs_compiled_object = Native then + begin + try + var_ignore_eval BaseStandardVar.ocamlopt + with e -> + warn_exception e; + add_errors + (f_ "Section %s requires native compilation") + (OASISSection.string_of_section sct) + end; + + (* Check tools *) + check_tools bs.bs_build_tools; + + (* Check depends *) + List.iter + (function + | FindlibPackage (findlib_pkg, version_comparator) -> + begin + try + var_ignore_eval + (BaseCheck.package ?version_comparator findlib_pkg) + with e -> + warn_exception e; + match version_comparator with + | None -> + add_errors + (f_ "Cannot find findlib package %s") + findlib_pkg + | Some ver_cmp -> + add_errors + (f_ "Cannot find findlib package %s (%s)") + findlib_pkg + (OASISVersion.string_of_comparator ver_cmp) + end + | InternalLibrary nm1 -> + (* Check that matching library is built *) + List.iter + (function + | Library ({cs_name = nm2}, + {bs_build = build}, + _) when nm1 = nm2 -> + if not (var_choose build) then + add_errors + (f_ "Cannot find buildable internal library \ + '%s' when checking build depends") + nm1 + | _ -> + ()) + pkg.sections) + bs.bs_build_depends + end + in + + (* Parse command line *) + BaseArgExt.parse argv (BaseEnv.args ()); + + (* OCaml version *) + begin + match pkg.ocaml_version with + | Some ver_cmp -> + begin + try + var_ignore_eval + (BaseCheck.version + "ocaml" + ver_cmp + BaseStandardVar.ocaml_version) + with e -> + warn_exception e; + add_errors + (f_ "OCaml version %s doesn't match version constraint %s") + (BaseStandardVar.ocaml_version ()) + (OASISVersion.string_of_comparator ver_cmp) + end + | None -> + () + end; + + (* Findlib version *) + begin + match pkg.findlib_version with + | Some ver_cmp -> + begin + try + var_ignore_eval + (BaseCheck.version + "findlib" + ver_cmp + BaseStandardVar.findlib_version) + with e -> + warn_exception e; + add_errors + (f_ "Findlib version %s doesn't match version constraint %s") + (BaseStandardVar.findlib_version ()) + (OASISVersion.string_of_comparator ver_cmp) + end + | 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" || + BaseStandardVar.os_type () = "Cygwin" then + begin + try + var_ignore_eval BaseStandardVar.flexlink + with e -> + warn_exception e; + add_errors (f_ "Cannot find 'flexlink'") + end; + + (* Check build depends *) + List.iter + (function + | Executable (_, bs, _) + | Library (_, bs, _) as sct -> + build_checks sct bs + | Doc (_, doc) -> + if var_choose doc.doc_build then + check_tools doc.doc_build_tools + | Test (_, test) -> + if var_choose test.test_run then + check_tools test.test_tools + | _ -> + ()) + pkg.sections; + + (* Check if we need native dynlink (presence of libraries that compile to + * native) + *) + begin + let has_cmxa = + List.exists + (function + | Library (_, bs, _) -> + var_choose bs.bs_build && + (bs.bs_compiled_object = Native || + (bs.bs_compiled_object = Best && + bool_of_string (BaseStandardVar.is_native ()))) + | _ -> + false) + pkg.sections + in + if has_cmxa then + var_ignore_eval BaseStandardVar.native_dynlink + end; + + (* Check errors *) + if SetString.empty != !errors then + begin + List.iter + (fun e -> error "%s" e) + (SetString.elements !errors); + failwithf + (fn_ + "%d configuration error" + "%d configuration errors" + (SetString.cardinal !errors)) + (SetString.cardinal !errors) + end + + +end + +module InternalInstallPlugin = struct +(* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *) + + + (** Install using internal scheme + @author Sylvain Le Gall + *) + + + open BaseEnv + open BaseStandardVar + open BaseMessage + open OASISTypes + open OASISFindlib + open OASISGettext + open OASISUtils + + + let exec_hook = + ref (fun (cs, bs, exec) -> cs, bs, exec) + + + 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) + + + let install_file_ev = + "install-file" + + + let install_dir_ev = + "install-dir" + + + let install_findlib_ev = + "install-findlib" + + + let win32_max_command_line_length = 8000 + + + let split_install_command ocamlfind findlib_name meta files = + if Sys.os_type = "Win32" then + (* Arguments for the first command: *) + let first_args = ["install"; findlib_name; meta] in + (* Arguments for remaining commands: *) + let other_args = ["install"; findlib_name; "-add"] in + (* Extract as much files as possible from [files], [len] is + the current command line length: *) + let rec get_files len acc files = + match files with + | [] -> + (List.rev acc, []) + | file :: rest -> + let len = len + 1 + String.length file in + if len > win32_max_command_line_length then + (List.rev acc, files) + else + get_files len (file :: acc) rest + in + (* Split the command into several commands. *) + let rec split args files = + match files with + | [] -> + [] + | _ -> + (* Length of "ocamlfind install [META|-add]" *) + let len = + List.fold_left + (fun len arg -> + len + 1 (* for the space *) + String.length arg) + (String.length ocamlfind) + args + in + match get_files len [] files with + | ([], _) -> + failwith (s_ "Command line too long.") + | (firsts, others) -> + let cmd = args @ firsts in + (* Use -add for remaining commands: *) + let () = + let findlib_ge_132 = + OASISVersion.comparator_apply + (OASISVersion.version_of_string + (BaseStandardVar.findlib_version ())) + (OASISVersion.VGreaterEqual + (OASISVersion.version_of_string "1.3.2")) + in + if not findlib_ge_132 then + failwithf + (f_ "Installing the library %s require to use the \ + flag '-add' of ocamlfind because the command \ + line is too long. This flag is only available \ + for findlib 1.3.2. Please upgrade findlib from \ + %s to 1.3.2") + findlib_name (BaseStandardVar.findlib_version ()) + in + let cmds = split other_args others in + cmd :: cmds + in + (* The first command does not use -add: *) + split first_args files + else + ["install" :: findlib_name :: meta :: files] + + + let install pkg argv = + + let in_destdir = + try + let destdir = + destdir () + in + (* Practically speaking destdir is prepended + * at the beginning of the target filename + *) + fun fn -> destdir^fn + with PropList.Not_set _ -> + fun fn -> fn + in + + let install_file ?tgt_fn src_file envdir = + let tgt_dir = + in_destdir (envdir ()) + in + let tgt_file = + Filename.concat + tgt_dir + (match tgt_fn with + | Some fn -> + fn + | None -> + Filename.basename src_file) + in + (* Create target directory if needed *) + OASISFileUtil.mkdir_parent + ~ctxt:!BaseContext.default + (fun dn -> + info (f_ "Creating directory '%s'") dn; + BaseLog.register install_dir_ev dn) + tgt_dir; + + (* Really install files *) + info (f_ "Copying file '%s' to '%s'") src_file tgt_file; + OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file; + BaseLog.register install_file_ev tgt_file + in + + (* Install data into defined directory *) + let install_data srcdir lst tgtdir = + let tgtdir = + OASISHostPath.of_unix (var_expand tgtdir) + in + List.iter + (fun (src, tgt_opt) -> + let real_srcs = + OASISFileUtil.glob + ~ctxt:!BaseContext.default + (Filename.concat srcdir src) + in + if real_srcs = [] then + failwithf + (f_ "Wildcard '%s' doesn't match any files") + src; + List.iter + (fun fn -> + install_file + fn + (fun () -> + match tgt_opt with + | Some s -> + OASISHostPath.of_unix (var_expand s) + | None -> + tgtdir)) + real_srcs) + lst + in + + (** Install all libraries *) + let install_libs pkg = + + let files_of_library (f_data, acc) data_lib = + let cs, bs, lib, lib_extra = + !lib_hook data_lib + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then + begin + let acc = + (* Start with acc + lib_extra *) + List.rev_append lib_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 library %s") + modul cs.cs_name; + acc + end) + acc + lib.lib_modules + in + + let acc = + (* Get generated files *) + BaseBuilt.fold + BaseBuilt.BLib + cs.cs_name + (fun acc fn -> fn :: acc) + acc + in + + let f_data () = + (* Install data associated with the library *) + 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 + 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 *) + let install_group_lib grp = + (* Iterate through all group nodes *) + let rec install_group_lib_aux data_and_files grp = + let data_and_files, children = + match grp with + | Container (_, children) -> + data_and_files, 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 + data_and_files + children + in + + (* Findlib name of the root library *) + let findlib_name = + findlib_of_group grp + in + + (* Determine root library *) + let root_lib = + root_of_group grp + in + + (* All files to install for this library *) + let f_data, files = + install_group_lib_aux (ignore, []) grp + in + + (* Really install, if there is something to install *) + if files = [] then + begin + warning + (f_ "Nothing to install for findlib library '%s'") + findlib_name + end + else + begin + let meta = + (* Search META file *) + let _, bs, _ = + root_lib + in + let res = + Filename.concat bs.bs_path "META" + in + if not (OASISFileUtil.file_exists_case res) then + failwithf + (f_ "Cannot find file '%s' for findlib library %s") + res + findlib_name; + res + in + let files = + (* Make filename shorter to avoid hitting command max line length + * too early, esp. on Windows. + *) + let remove_prefix p n = + let plen = String.length p in + let nlen = String.length n in + if plen <= nlen && String.sub n 0 plen = p then + begin + let fn_sep = + if Sys.os_type = "Win32" then + '\\' + else + '/' + in + let cutpoint = plen + + (if plen < nlen && n.[plen] = fn_sep then + 1 + else + 0) + in + String.sub n cutpoint (nlen - cutpoint) + end + else + n + in + List.map (remove_prefix (Sys.getcwd ())) files + in + info + (f_ "Installing findlib library '%s'") + findlib_name; + let ocamlfind = ocamlfind () in + let commands = + split_install_command + ocamlfind + findlib_name + meta + files + in + List.iter + (OASISExec.run ~ctxt:!BaseContext.default ocamlfind) + commands; + BaseLog.register install_findlib_ev findlib_name + end; + + (* Install data files *) + f_data (); + + in + + let group_libs, _, _ = + findlib_mapping pkg + in + + (* We install libraries in groups *) + List.iter install_group_lib group_libs + in + + let install_execs pkg = + let install_exec data_exec = + let cs, bs, exec = + !exec_hook data_exec + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then + begin + let exec_libdir () = + Filename.concat + (libdir ()) + pkg.name + in + BaseBuilt.fold + BaseBuilt.BExec + cs.cs_name + (fun () fn -> + install_file + ~tgt_fn:(cs.cs_name ^ ext_program ()) + fn + bindir) + (); + BaseBuilt.fold + BaseBuilt.BExecLib + cs.cs_name + (fun () fn -> + install_file + fn + exec_libdir) + (); + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name) + end + in + List.iter + (function + | Executable (cs, bs, exec)-> + install_exec (cs, bs, exec) + | _ -> + ()) + pkg.sections + in + + let install_docs pkg = + let install_doc data = + let cs, doc = + !doc_hook data + in + if var_choose doc.doc_install && + BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then + begin + let tgt_dir = + OASISHostPath.of_unix (var_expand doc.doc_install_dir) + in + BaseBuilt.fold + BaseBuilt.BDoc + cs.cs_name + (fun () fn -> + install_file + fn + (fun () -> tgt_dir)) + (); + install_data + Filename.current_dir_name + doc.doc_data_files + doc.doc_install_dir + end + in + List.iter + (function + | Doc (cs, doc) -> + install_doc (cs, doc) + | _ -> + ()) + pkg.sections + in + + install_libs pkg; + install_execs pkg; + install_docs pkg + + + (* Uninstall already installed data *) + let uninstall _ argv = + List.iter + (fun (ev, data) -> + if ev = install_file_ev then + begin + if OASISFileUtil.file_exists_case data then + begin + info + (f_ "Removing file '%s'") + data; + Sys.remove data + end + else + begin + warning + (f_ "File '%s' doesn't exist anymore") + data + end + end + else if ev = install_dir_ev then + begin + if Sys.file_exists data && Sys.is_directory data then + begin + if Sys.readdir data = [||] then + begin + info + (f_ "Removing directory '%s'") + data; + OASISFileUtil.rmdir ~ctxt:!BaseContext.default data + end + else + begin + warning + (f_ "Directory '%s' is not empty (%s)") + data + (String.concat + ", " + (Array.to_list + (Sys.readdir data))) + end + end + else + begin + warning + (f_ "Directory '%s' doesn't exist anymore") + data + end + end + else if ev = install_findlib_ev then + begin + info (f_ "Removing findlib library '%s'") data; + OASISExec.run ~ctxt:!BaseContext.default + (ocamlfind ()) ["remove"; data] + end + else + failwithf (f_ "Unknown log event '%s'") ev; + BaseLog.unregister ev data) + (* We process event in reverse order *) + (List.rev + (BaseLog.filter + [install_file_ev; + install_dir_ev; + install_findlib_ev])) + + +end + + +# 6243 "setup.ml" +module OCamlbuildCommon = struct +(* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) + + + (** Functions common to OCamlbuild build and doc plugin + *) + + + open OASISGettext + open BaseEnv + open BaseStandardVar + open OASISTypes + + + + + type extra_args = string list + + + let ocamlbuild_clean_ev = "ocamlbuild-clean" + + + let ocamlbuildflags = + var_define + ~short_desc:(fun () -> "OCamlbuild additional flags") + "ocamlbuildflags" + (fun () -> "") + + + (** Fix special arguments depending on environment *) + let fix_args args extra_argv = + List.flatten + [ + if (os_type ()) = "Win32" then + [ + "-classic-display"; + "-no-log"; + "-no-links"; + "-install-lib-dir"; + (Filename.concat (standard_library ()) "ocamlbuild") + ] + else + []; + + if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then + [ + "-byte-plugin" + ] + else + []; + args; + + if bool_of_string (debug ()) then + ["-tag"; "debug"] + else + []; + + if bool_of_string (profile ()) then + ["-tag"; "profile"] + else + []; + + OASISString.nsplit (ocamlbuildflags ()) ' '; + + Array.to_list extra_argv; + ] + + + (** Run 'ocamlbuild -clean' if not already done *) + let run_clean extra_argv = + let extra_cli = + String.concat " " (Array.to_list extra_argv) + in + (* Run if never called with these args *) + if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then + begin + OASISExec.run ~ctxt:!BaseContext.default + (ocamlbuild ()) (fix_args ["-clean"] extra_argv); + BaseLog.register ocamlbuild_clean_ev extra_cli; + at_exit + (fun () -> + try + BaseLog.unregister ocamlbuild_clean_ev extra_cli + with _ -> + ()) + end + + + (** Run ocamlbuild, unregister all clean events *) + let run_ocamlbuild args extra_argv = + (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html + *) + OASISExec.run ~ctxt:!BaseContext.default + (ocamlbuild ()) (fix_args args extra_argv); + (* Remove any clean event, we must run it again *) + List.iter + (fun (e, d) -> BaseLog.unregister e d) + (BaseLog.filter [ocamlbuild_clean_ev]) + + + (** Determine real build directory *) + let build_dir extra_argv = + let rec search_args dir = + function + | "-build-dir" :: dir :: tl -> + search_args dir tl + | _ :: tl -> + search_args dir tl + | [] -> + dir + in + search_args "_build" (fix_args [] extra_argv) + + +end + +module OCamlbuildPlugin = struct +(* # 22 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) + + + (** Build using ocamlbuild + @author Sylvain Le Gall + *) + + + open OASISTypes + open OASISGettext + open OASISUtils + open OASISString + open BaseEnv + open OCamlbuildCommon + open BaseStandardVar + open BaseMessage + + + + + + let cond_targets_hook = + ref (fun lst -> lst) + + + let build extra_args pkg argv = + (* Return the filename in build directory *) + let in_build_dir fn = + Filename.concat + (build_dir argv) + fn + in + + (* Return the unix filename in host build directory *) + let in_build_dir_of_unix fn = + in_build_dir (OASISHostPath.of_unix fn) + in + + let cond_targets = + List.fold_left + (fun acc -> + function + | Library (cs, bs, lib) when var_choose bs.bs_build -> + begin + let evs, unix_files = + BaseBuilt.of_library + in_build_dir_of_unix + (cs, bs, lib) + in + + let tgts = + List.flatten + (List.filter + (fun l -> l <> []) + (List.map + (List.filter + (fun fn -> + ends_with ~what:".cma" fn + || ends_with ~what:".cmxs" fn + || ends_with ~what:".cmxa" fn + || ends_with ~what:(ext_lib ()) fn + || ends_with ~what:(ext_dll ()) fn)) + unix_files)) + in + + match tgts with + | _ :: _ -> + (evs, tgts) :: acc + | [] -> + failwithf + (f_ "No possible ocamlbuild targets for library %s") + 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 = + BaseBuilt.of_executable + in_build_dir_of_unix + (cs, bs, exec) + in + + let target ext = + let unix_tgt = + (OASISUnixPath.concat + bs.bs_path + (OASISUnixPath.chop_extension + exec.exec_main_is))^ext + in + let evs = + (* Fix evs, we want to use the unix_tgt, without copying *) + List.map + (function + | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> + BaseBuilt.BExec, nm, + [[in_build_dir_of_unix unix_tgt]] + | ev -> + ev) + evs + in + evs, [unix_tgt] + in + + (* Add executable *) + let acc = + 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 _ + | SrcRepo _ | Flag _ | Doc _ -> + acc) + [] + (* Keep the pkg.sections ordered *) + (List.rev pkg.sections); + in + + (* Check and register built files *) + let check_and_register (bt, bnm, lst) = + List.iter + (fun fns -> + if not (List.exists OASISFileUtil.file_exists_case fns) then + failwithf + (fn_ + "Expected built file %s doesn't exist." + "None of expected built files %s exists." + (List.length fns)) + (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) + lst; + (BaseBuilt.register bt bnm lst) + in + + (* Run the hook *) + let cond_targets = !cond_targets_hook cond_targets in + + (* Run a list of target... *) + run_ocamlbuild (List.flatten (List.map snd cond_targets) @ extra_args) argv; + (* ... and register events *) + List.iter check_and_register (List.flatten (List.map fst cond_targets)) + + + let clean pkg extra_args = + run_clean extra_args; + List.iter + (function + | Library (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BLib cs.cs_name + | Executable (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; + BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name + | _ -> + ()) + pkg.sections + + +end + +module OCamlbuildDocPlugin = struct +(* # 22 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) + + + (* Create documentation using ocamlbuild .odocl files + @author Sylvain Le Gall + *) + + + open OASISTypes + open OASISGettext + open OASISMessage + open OCamlbuildCommon + open BaseStandardVar + + + + + type run_t = + { + extra_args: string list; + run_path: unix_filename; + } + + + let doc_build run pkg (cs, doc) argv = + let index_html = + OASISUnixPath.make + [ + run.run_path; + cs.cs_name^".docdir"; + "index.html"; + ] + in + let tgt_dir = + OASISHostPath.make + [ + build_dir argv; + OASISHostPath.of_unix run.run_path; + cs.cs_name^".docdir"; + ] + in + run_ocamlbuild (index_html :: run.extra_args) argv; + List.iter + (fun glb -> + BaseBuilt.register + BaseBuilt.BDoc + cs.cs_name + [OASISFileUtil.glob ~ctxt:!BaseContext.default + (Filename.concat tgt_dir glb)]) + ["*.html"; "*.css"] + + + let doc_clean run pkg (cs, doc) argv = + run_clean argv; + BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name + + +end + + +# 6616 "setup.ml" +module CustomPlugin = struct +(* # 22 "src/plugins/custom/CustomPlugin.ml" *) + + + (** Generate custom configure/build/doc/test/install system + @author + *) + + + open BaseEnv + open OASISGettext + open OASISTypes + + + + + + type t = + { + cmd_main: command_line conditional; + cmd_clean: (command_line option) conditional; + cmd_distclean: (command_line option) conditional; + } + + + let run = BaseCustom.run + + + let main t _ extra_args = + let cmd, args = + var_choose + ~name:(s_ "main command") + t.cmd_main + in + run cmd args extra_args + + + let clean t pkg extra_args = + match var_choose t.cmd_clean with + | Some (cmd, args) -> + run cmd args extra_args + | _ -> + () + + + let distclean t pkg extra_args = + match var_choose t.cmd_distclean with + | Some (cmd, args) -> + run cmd args extra_args + | _ -> + () + + + module Build = + struct + let main t pkg extra_args = + main t pkg extra_args; + List.iter + (fun sct -> + let evs = + match sct with + | Library (cs, bs, lib) when var_choose bs.bs_build -> + begin + let evs, _ = + BaseBuilt.of_library + OASISHostPath.of_unix + (cs, bs, lib) + in + evs + end + | Executable (cs, bs, exec) when var_choose bs.bs_build -> + begin + let evs, _, _ = + BaseBuilt.of_executable + OASISHostPath.of_unix + (cs, bs, exec) + in + evs + end + | _ -> + [] + in + List.iter + (fun (bt, bnm, lst) -> BaseBuilt.register bt bnm lst) + evs) + pkg.sections + + let clean t pkg extra_args = + clean t pkg extra_args; + (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild + * considering moving this to BaseSetup? + *) + List.iter + (function + | Library (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BLib cs.cs_name + | Executable (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; + BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name + | _ -> + ()) + pkg.sections + + let distclean t pkg extra_args = + distclean t pkg extra_args + end + + + module Test = + struct + let main t pkg (cs, test) extra_args = + try + main t pkg extra_args; + 0.0 + with Failure s -> + BaseMessage.warning + (f_ "Test '%s' fails: %s") + cs.cs_name + s; + 1.0 + + let clean t pkg (cs, test) extra_args = + clean t pkg extra_args + + let distclean t pkg (cs, test) extra_args = + distclean t pkg extra_args + end + + + module Doc = + struct + let main t pkg (cs, _) extra_args = + main t pkg extra_args; + BaseBuilt.register BaseBuilt.BDoc cs.cs_name [] + + let clean t pkg (cs, _) extra_args = + clean t pkg extra_args; + BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name + + let distclean t pkg (cs, _) extra_args = + distclean t pkg extra_args + end + + +end + + +# 6764 "setup.ml" +open OASISTypes;; + +let setup_t = + { + BaseSetup.configure = InternalConfigurePlugin.configure; + build = OCamlbuildPlugin.build []; + test = + [ + ("test_networkd", + CustomPlugin.Test.main + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$network_test", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)] + }) + ]; + doc = []; + install = InternalInstallPlugin.install; + uninstall = InternalInstallPlugin.uninstall; + clean = [OCamlbuildPlugin.clean]; + clean_test = + [ + ("test_networkd", + CustomPlugin.Test.clean + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$network_test", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)] + }) + ]; + clean_doc = []; + distclean = []; + distclean_test = + [ + ("test_networkd", + CustomPlugin.Test.distclean + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$network_test", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)] + }) + ]; + distclean_doc = []; + package = + { + oasis_version = "0.3"; + ocaml_version = None; + findlib_version = None; + alpha_features = []; + beta_features = []; + name = "xcp-networkd"; + version = "0.9.4"; + license = + OASISLicense.DEP5License + (OASISLicense.DEP5Unit + { + OASISLicense.license = "LGPL"; + excption = Some "OCaml linking"; + version = OASISLicense.Version "2.1" + }); + license_file = None; + copyrights = []; + maintainers = []; + authors = ["Rob Hoes"]; + homepage = None; + synopsis = "XCP Network Daemon"; + description = None; + categories = []; + conf_type = (`Configure, "internal", Some "0.4"); + conf_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + build_type = (`Build, "ocamlbuild", Some "0.4"); + build_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + install_type = (`Install, "internal", Some "0.4"); + install_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + uninstall_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + clean_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + distclean_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + files_ab = []; + sections = + [ + Library + ({ + cs_name = "networklibs"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "lib"; + bs_compiled_object = Best; + bs_build_depends = + [ + FindlibPackage ("forkexec", None); + FindlibPackage ("stdext", None); + FindlibPackage ("threads", None); + FindlibPackage ("rpclib", None); + FindlibPackage ("stdext", None); + FindlibPackage ("xcp-inventory", None); + FindlibPackage ("xcp.network", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = ["link_stubs.c"; "netdev.h"]; + bs_data_files = []; + bs_ccopt = + [ + (OASISExpr.EBool true, + ["-Wno-unused-function"; "-g"; "-ggdb"]) + ]; + 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, [])] + }, + { + lib_modules = ["Network_config"; "Network_utils"]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = None; + lib_findlib_name = Some "network-libs"; + lib_findlib_containers = [] + }); + Executable + ({ + cs_name = "xcp_networkd"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "networkd"; + bs_compiled_object = Best; + bs_build_depends = + [ + FindlibPackage ("threads", None); + FindlibPackage ("rpclib", None); + FindlibPackage ("rpclib.unix", None); + FindlibPackage ("forkexec", None); + FindlibPackage ("stdext", None); + FindlibPackage ("xcp-inventory", None); + InternalLibrary "networklibs"; + FindlibPackage ("xen-api-client", None); + FindlibPackage ("xcp", None); + FindlibPackage ("xcp.network", 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 = "networkd.ml"}); + Executable + ({ + cs_name = "networkd_db"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "networkd_db"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "networklibs"; + FindlibPackage ("stdext", None); + FindlibPackage ("threads", None); + FindlibPackage ("xcp.network", 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 = "networkd_db.ml"}); + Executable + ({ + cs_name = "network_test"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "test"; + bs_compiled_object = Best; + bs_build_depends = + [ + FindlibPackage ("stdext", None); + FindlibPackage ("oUnit", None); + InternalLibrary "networklibs" + ]; + 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 = false; exec_main_is = "network_test.ml"}); + Test + ({ + cs_name = "test_networkd"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + test_type = (`Test, "custom", Some "0.4"); + test_command = + [(OASISExpr.EBool true, ("$network_test", []))]; + test_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + test_working_directory = Some "."; + test_run = + [ + (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); + (OASISExpr.EFlag "tests", false); + (OASISExpr.EAnd + (OASISExpr.EFlag "tests", + OASISExpr.EFlag "tests"), + true) + ]; + test_tools = [ExternalTool "ocamlbuild"] + }) + ]; + plugins = [(`Extra, "META", Some "0.2")]; + disable_oasis_section = []; + schema_data = PropList.Data.create (); + plugin_data = [] + }; + oasis_fn = Some "_oasis"; + oasis_version = "0.4.4"; + oasis_digest = Some "^\179\199[\222\\\135\148\248p\223z\230\242E9"; + oasis_exec = None; + oasis_setup_args = []; + setup_update = false + };; + +let setup () = BaseSetup.setup setup_t;; + +# 7051 "setup.ml" +(* OASIS_STOP *) +let () = setup ();; From 4999fd61ed3e28b0f070695f99ce63dadd989d2a Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Wed, 3 Jul 2013 17:29:31 +0100 Subject: [PATCH 021/260] Get network stats through netlink rather than from /proc This add a dependency to the netlink opam package, and the libnl-3 and libnl-route-3 libraries. Signed-off-by: Rob Hoes --- networkd/network_monitor_thread.ml | 77 ++++++++++++++++-------------- xcp-networkd.obuild | 2 +- 2 files changed, 43 insertions(+), 36 deletions(-) diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index 606fd250b..3a357b225 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -82,46 +82,53 @@ let check_for_changes ~(dev : string) ~(stat : Network_monitor.iface_stats) = let failed_again = ref false +let standardise_name name = + try + let (d1,d2) = Scanf.sscanf name "tap%d.%d" + (fun d1 d2 -> d1,d2) in + let newname = Printf.sprintf "vif%d.%d" d1 d2 in + newname + with _ -> name + +let get_link_stats () = + let open Network_monitor in + let open Netlink in + let s = Socket.alloc () in + Socket.connect s Socket.NETLINK_ROUTE; + + let cache = Link.cache_alloc s in + let links = Link.cache_to_list cache in + let devs = List.map (fun link -> + let name = standardise_name (Link.get_name link) in + let convert x = Int64.of_int (Unsigned.UInt64.to_int x) in + let eth_stat = {default_stats with + rx_bytes = Link.get_stat link Link.RX_BYTES |> convert; + rx_pkts = Link.get_stat link Link.RX_PACKETS |> convert; + rx_errors = Link.get_stat link Link.RX_ERRORS |> convert; + tx_bytes = Link.get_stat link Link.TX_BYTES |> convert; + tx_pkts = Link.get_stat link Link.TX_PACKETS |> convert; + tx_errors = Link.get_stat link Link.TX_ERRORS |> convert; + } in + name, eth_stat + ) links in + let devs = List.filter (fun (name, _) -> + not(String.startswith "dummy" name) && + not(String.startswith "xenbr" name) && + not(String.startswith "xapi" name) && + not(String.startswith "eth" name && String.contains name '.') + ) devs in + + Cache.free cache; + Socket.close s; + Socket.free s; + devs + let rec monitor dbg () = let open Network_interface in let open Network_monitor in (try let devs = ref [] in - - let standardise_name name = - try - let (d1,d2) = Scanf.sscanf name "tap%d.%d" - (fun d1 d2 -> d1,d2) in - let newname = Printf.sprintf "vif%d.%d" d1 d2 in - newname - with _ -> name - in - - let f line = - if String.contains line ':' then ( - let flds = String.split_f (fun c -> c = ' ' || c = ':') line in - let flds = List.filter (fun field -> field <> "") flds in - let name = standardise_name (List.nth flds 0) in - let vs = List.map (fun i -> - try Int64.of_string (List.nth flds i) with _ -> 0L) - [ 1; 2; 3; 9; 10; 11; ] in - let eth_stat = {default_stats with - rx_bytes = List.nth vs 0; - rx_pkts = List.nth vs 1; - rx_errors = List.nth vs 2; - tx_bytes = List.nth vs 3; - tx_pkts = List.nth vs 4; - tx_errors = List.nth vs 5; - } in - (* CA-23291: no good can come of recording 'dummy' device stats *) - if not(String.startswith "dummy" name) && - not(String.startswith "xenbr" name) && - not(String.startswith "xapi" name) && - not(String.startswith "eth" name && String.contains name '.') - then devs := (name,eth_stat) :: (!devs) - ) - in - Unixext.readfile_line f "/proc/net/dev"; + devs := get_link_stats (); let make_bond_info (name, interfaces) = let devs = List.filter (fun (name', _) -> List.mem name' interfaces) !devs in diff --git a/xcp-networkd.obuild b/xcp-networkd.obuild index 1bc389914..8b0ff8195 100644 --- a/xcp-networkd.obuild +++ b/xcp-networkd.obuild @@ -13,7 +13,7 @@ library network-libs executable xcp-networkd main: networkd.ml src-dir: networkd - build-deps: threads, rpclib, rpclib.unix, forkexec, stdext, xcp-inventory, network-libs, xen-api-client, xcp, xcp.network + build-deps: threads, rpclib, rpclib.unix, forkexec, stdext, xcp-inventory, network-libs, xen-api-client, xcp, xcp.network, netlink pp: camlp4o executable networkd_db From 29e3aa968822cc5e5c225aab3c40b6f391f926de Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 6 Jun 2014 16:04:03 +0100 Subject: [PATCH 022/260] Update oasis Signed-off-by: Rob Hoes --- _oasis | 2 +- _tags | 4 +- myocamlbuild.ml | 47 ++++------ setup.ml | 237 +++++++++++++++--------------------------------- 4 files changed, 92 insertions(+), 198 deletions(-) diff --git a/_oasis b/_oasis index bf17b223b..88958d14f 100644 --- a/_oasis +++ b/_oasis @@ -22,7 +22,7 @@ Executable xcp_networkd MainIs: networkd.ml Custom: true Install: false - BuildDepends: threads, rpclib, rpclib.unix, forkexec, stdext, xcp-inventory, network-libs, xen-api-client, xcp, xcp.network + BuildDepends: threads, rpclib, rpclib.unix, forkexec, stdext, xcp-inventory, network-libs, xen-api-client, xcp, xcp.network, netlink Executable networkd_db CompiledObject: best diff --git a/_tags b/_tags index 34f629423..029f7bd59 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 6dce1a9a50f608514e51caf58ef0ebc9) +# DO NOT EDIT (digest: 25ce055fb4cc4259cfd4fd1e986a20f1) # 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 @@ -32,6 +32,7 @@ "lib/link_stubs.c": pkg_xcp.network # Executable xcp_networkd : pkg_forkexec +: pkg_netlink : pkg_rpclib : pkg_rpclib.unix : pkg_stdext @@ -42,6 +43,7 @@ : pkg_xen-api-client : use_networklibs : pkg_forkexec +: pkg_netlink : pkg_rpclib : pkg_rpclib.unix : pkg_stdext diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 8ec5d77b9..9ba62daf2 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 1b562e89c2fc3873269cda485f3abe87) *) +(* DO NOT EDIT (digest: b61c6662b23d9ed3268fd3f519fdb137) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) @@ -259,31 +259,6 @@ module MyOCamlbuildFindlib = struct Ocamlbuild_pack.Lexers.blank_sep_strings - let exec_from_conf exec = - let exec = - let env_filename = Pathname.basename BaseEnvLight.default_filename in - let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in - try - BaseEnvLight.var_get exec env - with Not_found -> - Printf.eprintf "W: Cannot get variable %s\n" exec; - exec - in - let fix_win32 str = - if Sys.os_type = "Win32" then begin - let buff = Buffer.create (String.length str) in - (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. - *) - String.iter - (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) - str; - Buffer.contents buff - end else begin - str - end - in - fix_win32 exec - let split s ch = let buf = Buffer.create 13 in let x = ref [] in @@ -311,7 +286,17 @@ module MyOCamlbuildFindlib = struct with Not_found -> s (* ocamlfind command *) - let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] + let ocamlfind x = + let ocamlfind_prog = + let env_filename = Pathname.basename BaseEnvLight.default_filename in + let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in + try + BaseEnvLight.var_get "ocamlfind" env + with Not_found -> + Printf.eprintf "W: Cannot get variable ocamlfind"; + "ocamlfind" + in + S[Sh ocamlfind_prog; x] (* This lists all supported packages. *) let find_packages () = @@ -340,7 +325,7 @@ module MyOCamlbuildFindlib = struct let dispatch = function - | After_options -> + | Before_options -> (* By using Before_options one let command line options have an higher * priority on the contrary using After_options will guarantee to have * the higher priority override default commands by ocamlfind ones *) @@ -491,7 +476,7 @@ module MyOCamlbuildBase = struct try opt := no_trailing_dot (BaseEnvLight.var_get var env) with Not_found -> - Printf.eprintf "W: Cannot get variable %s\n" var) + Printf.eprintf "W: Cannot get variable %s" var) [ Options.ext_obj, "ext_obj"; Options.ext_lib, "ext_lib"; @@ -591,7 +576,7 @@ module MyOCamlbuildBase = struct end -# 594 "myocamlbuild.ml" +# 579 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { @@ -620,6 +605,6 @@ let package_default = let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; -# 624 "myocamlbuild.ml" +# 609 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/setup.ml b/setup.ml index c274d211b..b66076247 100644 --- a/setup.ml +++ b/setup.ml @@ -1,9 +1,9 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 8a544e6f7b2bc3fb2f97d5be41f7b1aa) *) +(* DO NOT EDIT (digest: 4af85109009a4a9acf4da8dcb4c88f5b) *) (* - Regenerated by OASIS v0.4.4 + Regenerated by OASIS v0.4.2 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) @@ -258,62 +258,29 @@ module OASISUtils = struct open OASISGettext - module MapExt = - struct - module type S = - sig - include Map.S - val add_list: 'a t -> (key * 'a) list -> 'a t - val of_list: (key * 'a) list -> 'a t - val to_list: 'a t -> (key * 'a) list - end - - module Make (Ord: Map.OrderedType) = - struct - include Map.Make(Ord) - - let rec add_list t = - function - | (k, v) :: tl -> add_list (add k v t) tl - | [] -> t - - let of_list lst = add_list empty lst - - let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] - end - end + module MapString = Map.Make(String) - module MapString = MapExt.Make(String) + let map_string_of_assoc assoc = + List.fold_left + (fun acc (k, v) -> MapString.add k v acc) + MapString.empty + assoc - module SetExt = - struct - module type S = - sig - include Set.S - val add_list: t -> elt list -> t - val of_list: elt list -> t - val to_list: t -> elt list - end - - module Make (Ord: Set.OrderedType) = - struct - include Set.Make(Ord) - - let rec add_list t = - function - | e :: tl -> add_list (add e t) tl - | [] -> t + module SetString = Set.Make(String) - let of_list lst = add_list empty lst - let to_list = elements - end - end + let set_string_add_list st lst = + List.fold_left + (fun acc e -> SetString.add e acc) + st + lst - module SetString = SetExt.Make(String) + let set_string_of_list = + set_string_add_list + SetString.empty let compare_csl s1 s2 = @@ -333,7 +300,7 @@ module OASISUtils = struct end) module SetStringCsl = - SetExt.Make + Set.Make (struct type t = string let compare = compare_csl @@ -1080,21 +1047,6 @@ module OASISExpr = struct end -module OASISText = struct -(* # 22 "src/oasis/OASISText.ml" *) - - - - type elt = - | Para of string - | Verbatim of string - | BlankLine - - - type t = elt list - -end - module OASISTypes = struct (* # 22 "src/oasis/OASISTypes.ml" *) @@ -1327,42 +1279,41 @@ module OASISTypes = struct type package = { - oasis_version: OASISVersion.t; - ocaml_version: OASISVersion.comparator option; - findlib_version: OASISVersion.comparator option; - alpha_features: string list; - beta_features: string list; - name: package_name; - version: OASISVersion.t; - license: OASISLicense.t; - license_file: unix_filename option; - copyrights: string list; - maintainers: string list; - authors: string list; - homepage: url option; - synopsis: string; - description: OASISText.t option; - categories: url list; - - conf_type: [`Configure] plugin; - conf_custom: custom; - - build_type: [`Build] plugin; - build_custom: custom; - - install_type: [`Install] plugin; - install_custom: custom; - uninstall_custom: custom; - - clean_custom: custom; - distclean_custom: custom; - - files_ab: unix_filename list; - sections: section list; - plugins: [`Extra] plugin list; - disable_oasis_section: unix_filename list; - schema_data: PropList.Data.t; - plugin_data: plugin_data; + oasis_version: OASISVersion.t; + ocaml_version: OASISVersion.comparator option; + findlib_version: OASISVersion.comparator option; + alpha_features: string list; + beta_features: string list; + name: package_name; + version: OASISVersion.t; + license: OASISLicense.t; + license_file: unix_filename option; + copyrights: string list; + maintainers: string list; + authors: string list; + homepage: url option; + synopsis: string; + description: string option; + categories: url list; + + conf_type: [`Configure] plugin; + conf_custom: custom; + + build_type: [`Build] plugin; + build_custom: custom; + + install_type: [`Install] plugin; + install_custom: custom; + uninstall_custom: custom; + + clean_custom: custom; + distclean_custom: custom; + + files_ab: unix_filename list; + sections: section list; + plugins: [`Extra] plugin list; + schema_data: PropList.Data.t; + plugin_data: plugin_data; } @@ -1416,24 +1367,6 @@ module OASISFeatures = struct let plugin_version plugin_kind plugin_name t = MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions - - let to_string t = - Printf.sprintf - "oasis_version: %s; alpha_features: %s; beta_features: %s; \ - plugins_version: %s" - (OASISVersion.string_of_version t.oasis_version) - (String.concat ", " t.alpha_features) - (String.concat ", " t.beta_features) - (String.concat ", " - (MapPlugin.fold - (fun (_, plg) ver_opt acc -> - (plg^ - (match ver_opt with - | Some v -> - " "^(OASISVersion.string_of_version v) - | None -> "")) - :: acc) - t.plugin_versions [])) end type origin = @@ -1474,17 +1407,6 @@ module OASISFeatures = struct let beta = InDev Beta - let to_string t = - Printf.sprintf - "feature: %s; plugin: %s; publication: %s" - t.name - (match t.plugin with - | None -> "" - | Some (_, nm, _) -> nm) - (match t.publication with - | InDev stage -> string_of_stage stage - | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) - let data_check t data origin = let no_message = "no message" in @@ -1717,18 +1639,6 @@ module OASISFeatures = struct create "dynrun_for_release" alpha (fun () -> s_ "Make '-setup-update dynamic' suitable for releasing project.") - - - let compiled_setup_ml = - create "compiled_setup_ml" alpha - (fun () -> - s_ "It compiles the setup.ml and speed-up actions done with it.") - - let disable_oasis_section = - create "disable_oasis_section" alpha - (fun () -> - s_ "Allows the OASIS section comments and digest to be omitted in \ - generated files.") end module OASISUnixPath = struct @@ -2817,17 +2727,14 @@ module OASISFileUtil = struct let rmdir ~ctxt tgt = - if Sys.readdir tgt = [||] then begin - match Sys.os_type with - | "Win32" -> - OASISExec.run ~ctxt "rd" [q tgt] - | _ -> - OASISExec.run ~ctxt "rm" ["-r"; q tgt] - end else begin - OASISMessage.error ~ctxt - (f_ "Cannot remove directory '%s': not empty.") - tgt - end + if Sys.readdir tgt = [||] then + begin + match Sys.os_type with + | "Win32" -> + OASISExec.run ~ctxt "rd" [q tgt] + | _ -> + OASISExec.run ~ctxt "rm" ["-r"; q tgt] + end let glob ~ctxt fn = @@ -2875,7 +2782,7 @@ module OASISFileUtil = struct end -# 2878 "setup.ml" +# 2785 "setup.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) @@ -2980,7 +2887,7 @@ module BaseEnvLight = struct end -# 2983 "setup.ml" +# 2890 "setup.ml" module BaseContext = struct (* # 22 "src/base/BaseContext.ml" *) @@ -5391,7 +5298,7 @@ module BaseSetup = struct end -# 5394 "setup.ml" +# 5301 "setup.ml" module InternalConfigurePlugin = struct (* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) @@ -6240,7 +6147,7 @@ module InternalInstallPlugin = struct end -# 6243 "setup.ml" +# 6150 "setup.ml" module OCamlbuildCommon = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) @@ -6613,7 +6520,7 @@ module OCamlbuildDocPlugin = struct end -# 6616 "setup.ml" +# 6523 "setup.ml" module CustomPlugin = struct (* # 22 "src/plugins/custom/CustomPlugin.ml" *) @@ -6761,7 +6668,7 @@ module CustomPlugin = struct end -# 6764 "setup.ml" +# 6671 "setup.ml" open OASISTypes;; let setup_t = @@ -6934,7 +6841,8 @@ let setup_t = InternalLibrary "networklibs"; FindlibPackage ("xen-api-client", None); FindlibPackage ("xcp", None); - FindlibPackage ("xcp.network", None) + FindlibPackage ("xcp.network", None); + FindlibPackage ("netlink", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -7033,13 +6941,12 @@ let setup_t = }) ]; plugins = [(`Extra, "META", Some "0.2")]; - disable_oasis_section = []; schema_data = PropList.Data.create (); plugin_data = [] }; oasis_fn = Some "_oasis"; - oasis_version = "0.4.4"; - oasis_digest = Some "^\179\199[\222\\\135\148\248p\223z\230\242E9"; + oasis_version = "0.4.2"; + oasis_digest = Some "\r\232-\232\227fs7j\240\016\152\179\188\188\""; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7047,6 +6954,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7051 "setup.ml" +# 6958 "setup.ml" (* OASIS_STOP *) let () = setup ();; From fda31cd368daf24c1b338c05c37581251d0e0ebb Mon Sep 17 00:00:00 2001 From: Ravi Pandey Date: Fri, 13 Jun 2014 09:19:42 +0100 Subject: [PATCH 023/260] CA-137227: Checking xen-backend in link of /sys/class/net/*/device/driver to identify vifs Signed-off-by: Ravi Pandey --- lib/network_utils.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 90ab69791..1cbddb41d 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -86,9 +86,10 @@ module Sysfs = struct let is_physical name = try - let link = Unix.readlink (getpath name "device") in - (* filter out device symlinks which look like /../../../devices/xen-backend/vif- *) - not(List.mem "xen-backend" (String.split '/' link)) + let devpath = getpath name "device" in + let driver_link = Unix.readlink (devpath ^ "/driver") in + (* filter out symlinks under device/driver which look like /../../../devices/xen-backend/vif- *) + not(List.mem "xen-backend" (String.split '/' driver_link)) with _ -> false let get_carrier name = From 13e53cf370b6dc44f05655a3030c80d9d3f9b0df Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Fri, 27 Jun 2014 23:45:06 +0100 Subject: [PATCH 024/260] Don't let naughty dhcp servers trick us into setting default routes. Signed-off-by: Jon Ludlam --- lib/network_utils.ml | 18 ++++++++++++++++-- networkd/network_server.ml | 10 +--------- 2 files changed, 17 insertions(+), 11 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 1cbddb41d..7e5a2e392 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -470,7 +470,11 @@ module Dhclient = struct let generate_conf ?(ipv6=false) interface options = let minimal = ["subnet-mask"; "broadcast-address"; "time-offset"; "host-name"; "nis-domain"; "nis-servers"; "ntp-servers"; "interface-mtu"] in - let set_gateway = if List.mem `set_gateway options then ["routers"] else [] in + let set_gateway = + if List.mem (`gateway interface) options + then (debug "%s is the default gateway interface" interface; ["routers"]) + else (debug "%s is NOT the default gateway interface" interface; []) + in let set_dns = if List.mem `set_dns options then ["domain-name"; "domain-name-servers"] else [] in let request = minimal @ set_gateway @ set_dns in Printf.sprintf "interface \"%s\" {\n request %s;\n}\n" interface (String.concat ", " request) @@ -484,9 +488,19 @@ module Dhclient = struct Unixext.write_string_to_file (conf_file ~ipv6 interface) conf let start ?(ipv6=false) interface options = + (* If we have a gateway interface, pass it to dhclient-script via -e *) + (* This prevents the default route being set erroneously on CentOS *) + (* Normally this wouldn't happen as we're not requesting routers, *) + (* but some buggy DHCP servers ignore this *) + (* See CA-137892 *) + let gw_opt = List.fold_left + (fun l x -> + match x with + | `gateway y -> ["-e"; "GATEWAYDEV="^y] + | _ -> l) [] options in write_conf_file ~ipv6 interface options; let ipv6' = if ipv6 then ["-6"] else [] in - call_script ~log_successful_output:true dhclient (ipv6' @ ["-q"; + call_script ~log_successful_output:true dhclient (ipv6' @ gw_opt @ ["-q"; "-pf"; pid_file ~ipv6 interface; "-lf"; lease_file ~ipv6 interface; "-cf"; conf_file ~ipv6 interface; diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 969413d3c..63f7d7671 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -133,15 +133,7 @@ module Interface = struct Ip.flush_ip_addr name end | DHCP4 -> - let gateway = - if !config.gateway_interface = None || !config.gateway_interface = Some name then begin - debug "%s is the default gateway interface" name; - [`set_gateway] - end else begin - debug "%s is NOT the default gateway interface" name; - [] - end - in + let gateway = Opt.default [] (Opt.map (fun n -> [`gateway n]) !config.gateway_interface) in let dns = if !config.dns_interface = None || !config.dns_interface = Some name then begin debug "%s is the DNS interface" name; From 87fa3de78d2d423debae8a08f7a3db6abd9881aa Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Mon, 14 Jul 2014 15:25:32 +0100 Subject: [PATCH 025/260] Don't record RRDs for the "ovs-system" interface This started appearing in the recent single-datapath OVSes, but does not really add anything useful. Signed-off-by: Rob Hoes --- networkd/network_monitor_thread.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index 3a357b225..91b8605b9 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -115,7 +115,8 @@ let get_link_stats () = not(String.startswith "dummy" name) && not(String.startswith "xenbr" name) && not(String.startswith "xapi" name) && - not(String.startswith "eth" name && String.contains name '.') + not(String.startswith "eth" name && String.contains name '.') && + name <> "ovs-system" ) devs in Cache.free cache; From 1acffd249414f000f1a2037abb26501716221621 Mon Sep 17 00:00:00 2001 From: Ravi Pandey Date: Fri, 1 Aug 2014 15:24:55 +0100 Subject: [PATCH 026/260] CA-137591: Removing all the interfaces before bringing the bridge down Signed-off-by: Ravi Pandey --- networkd/network_server.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 5f10c9d70..99a12df6b 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -524,6 +524,7 @@ module Bridge = struct remove_config name; List.iter (fun dev -> Interface.set_ipv4_conf () dbg ~name:dev ~conf:None4; + Brctl.destroy_port name dev; Interface.bring_down () dbg ~name:dev; if Linux_bonding.is_bond_device dev then Linux_bonding.remove_bond_master dev; From 3f28788fb090d415f1ad091e324fd4bb3e9290a0 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 8 Aug 2014 15:58:14 +0100 Subject: [PATCH 027/260] CA-140402: set max-idle to 5000ms on OVS Max-idle is an OVS setting that determines the idle timeout of flows in the kernel. Upstream OVS had reduced the timeout from 5000ms to 1500ms, causing kernel flows to be removed sooner. For flows that send packets with an interval that is a little larger than 1500ms, this means that every packet will result in an upcall to the OVS userspace. Tests have shown a relatively large impact on the dom0 CPU usage due to the reduced timeout. This patch puts the max-idle timeout back to 5000ms. Do this in xcp-networkd when it starts up. Signed-off-by: Rob Hoes --- lib/network_utils.ml | 6 ++++++ networkd/network_server.ml | 2 ++ 2 files changed, 8 insertions(+) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 7e5a2e392..01f6e89b5 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -663,6 +663,12 @@ module Ovs = struct nb_links with _ -> 0 + let set_max_idle t = + try + ignore (vsctl ["set"; "Open_vSwitch"; "."; Printf.sprintf "other_config:max-idle=%d" t]) + with _ -> + warn "Failed to set max-idle=%d on OVS" t + let handle_vlan_bug_workaround override bridge = (* This is a list of drivers that do support VLAN tx or rx acceleration, but * to which the VLAN bug workaround should not be applied. This could be diff --git a/networkd/network_server.ml b/networkd/network_server.ml index ca412757e..9c5f80238 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -769,6 +769,8 @@ let on_startup () = (* the following is best-effort *) read_config (); remove_centos_config (); + if !Bridge.kind = Openvswitch then + Ovs.set_max_idle 5000; Bridge.make_config () dbg ~conservative:true ~config:!config.bridge_config (); Interface.make_config () dbg ~conservative:true ~config:!config.interface_config (); (* If there is still a network.dbcache file, move it out of the way. *) From 9731c448ece36d0c8f8340f1e262a4583bca206f Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Tue, 24 Sep 2013 18:25:03 +0100 Subject: [PATCH 028/260] Use syslog from xcp-idl Signed-off-by: Jon Ludlam --- lib/network_config.ml | 2 +- lib/network_utils.ml | 2 +- networkd/network_monitor_thread.ml | 2 +- networkd/network_server.ml | 2 +- networkd/networkd.ml | 4 ++-- xcp-networkd.obuild | 4 ++-- 6 files changed, 8 insertions(+), 8 deletions(-) diff --git a/lib/network_config.ml b/lib/network_config.ml index c066694e4..fe0d969e8 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -17,7 +17,7 @@ open Network_interface open Fun open Stringext -module D = Debug.Debugger(struct let name = "network_config" end) +module D = Debug.Make(struct let name = "network_config" end) open D exception Read_error diff --git a/lib/network_utils.ml b/lib/network_utils.ml index d61addc2b..0096fc768 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -17,7 +17,7 @@ open Stringext open Fun open Network_interface -module D = Debug.Debugger(struct let name = "network_utils" end) +module D = Debug.Make(struct let name = "network_utils" end) open D let iproute2 = "/sbin/ip" diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index 6da0e568c..f0b7d7fba 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -19,7 +19,7 @@ open Stringext open Listext open Threadext -module D = Debug.Debugger(struct let name = "network_monitor_thread" end) +module D = Debug.Make(struct let name = "network_monitor_thread" end) open D (** Table for bonds status. *) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 740c880f8..d0c2b1401 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -19,7 +19,7 @@ open Fun open Stringext open Listext -module D = Debug.Debugger(struct let name = "network_server" end) +module D = Debug.Make(struct let name = "network_server" end) open D type context = unit diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 38ed7f949..f2d9762b7 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -16,7 +16,7 @@ open Pervasiveext open Fun open Network_utils -module D = Debug.Debugger(struct let name = "networkd" end) +module D = Debug.Make(struct let name = "networkd" end) open D module Server = Network_interface.Server(Network_server) @@ -65,7 +65,7 @@ let _ = Xcp_service.maybe_daemonize (); - Debug.set_facility Syslog_transitional.Local5; + Debug.set_facility Syslog.Local5; (* We should make the following configurable *) Debug.disable "http"; diff --git a/xcp-networkd.obuild b/xcp-networkd.obuild index 51fbc0cd5..5a413a820 100644 --- a/xcp-networkd.obuild +++ b/xcp-networkd.obuild @@ -6,14 +6,14 @@ obuild-ver: 1 library network-libs src-dir: lib modules: network_config, network_utils - build-deps: forkexec, stdext, threads, rpclib, log, stdext, xcp-inventory, xcp.network + build-deps: forkexec, stdext, threads, rpclib, stdext, xcp-inventory, xcp.network cdir: lib c-sources: link_stubs.c executable xcp-networkd main: networkd.ml src-dir: networkd - build-deps: threads, rpclib, rpclib.unix, forkexec, stdext, log, http-svr, xcp-inventory, network-libs, xen-api-client, xcp, xcp.network, netlink + build-deps: threads, rpclib, rpclib.unix, forkexec, stdext, http-svr, xcp-inventory, network-libs, xen-api-client, xcp, xcp.network, netlink pp: camlp4o executable networkd_db From 71af369d8ea7149434319e89e0ca291e2b189937 Mon Sep 17 00:00:00 2001 From: David Scott Date: Wed, 25 Sep 2013 15:14:13 +0000 Subject: [PATCH 029/260] Release 0.9.3 Signed-off-by: David Scott --- ChangeLog | 8 ++++++++ VERSION | 2 +- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index fc4b07012..d066396a8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +0.9.3 (24-Sep-2013): +* Allow the Bond.create to carry on even if the MTU size is invalid +* network monitor: better represent duplex mode for NIC bonds +* Use "ip link" to find the MAC address and MTU of a NIC +* Batch IP monitor changes for 1 second +* Signal xapi when an IP address is removed +* networkd: introduce Linklocal6 IPv6 address mode + 0.9.1 (7-Jun-2013): * monitor IPv4 address changes as well as IPv6 diff --git a/VERSION b/VERSION index 1892b9267..965065db5 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -1.3.2 +0.9.3 From 6ae2da66d9d9cb2282fd155547f8f806018109b2 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Thu, 26 Sep 2013 14:11:25 +0100 Subject: [PATCH 030/260] CA-105789: Ensure the bridge has the correct MAC on first boot Signed-off-by: Jon Ludlam --- lib/network_config.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lib/network_config.ml b/lib/network_config.ml index fe0d969e8..879e91664 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -34,6 +34,7 @@ let read_management_conf () = let device = List.assoc "LABEL" args in Inventory.reread_inventory (); let bridge_name = Inventory.lookup Inventory._management_interface in + let mac = Network_utils.Ip.get_mac bridge_name in debug "Management bridge in inventory file: %s" bridge_name; let ipv4_conf, ipv4_gateway, dns = match List.assoc "MODE" args with @@ -63,6 +64,7 @@ let read_management_conf () = let phy_interface = {default_interface with persistent_i = true} in let bridge_interface = {default_interface with ipv4_conf; ipv4_gateway; persistent_i = true} in let bridge = {default_bridge with + bridge_mac = Some mac; ports = [device, {default_port with interfaces = [device]}]; persistent_b = true } in From d6d529abfd48212457afe794185867a7f7f59f11 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Thu, 10 Oct 2013 14:29:25 +0100 Subject: [PATCH 031/260] Use the interface name, not the bridge name when looking up MAC This is for firstboot and for when xe-reset-networking has been executed. Acked-by: Rob Hoes Signed-off-by: Jon Ludlam --- lib/network_config.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/network_config.ml b/lib/network_config.ml index 879e91664..186a21127 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -34,8 +34,8 @@ let read_management_conf () = let device = List.assoc "LABEL" args in Inventory.reread_inventory (); let bridge_name = Inventory.lookup Inventory._management_interface in - let mac = Network_utils.Ip.get_mac bridge_name in debug "Management bridge in inventory file: %s" bridge_name; + let mac = Network_utils.Ip.get_mac device in let ipv4_conf, ipv4_gateway, dns = match List.assoc "MODE" args with | "static" -> From 8d0825bdb870064c775c5d96ead4815378df1b98 Mon Sep 17 00:00:00 2001 From: Mike McClurg Date: Wed, 23 Oct 2013 15:54:07 +0000 Subject: [PATCH 032/260] Add .merlin file Signed-off-by: Mike McClurg --- .merlin | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) create mode 100644 .merlin diff --git a/.merlin b/.merlin new file mode 100644 index 000000000..4b30ddf1f --- /dev/null +++ b/.merlin @@ -0,0 +1,19 @@ +S lib +S networkd +S networkd_db +S test +B dist/build/lib-network-libs/ +B dist/build/xcp-networkd +B dist/build/networkd_db +B dist/build/network_test +PKG forkexec +PKG rpclib +PKG stdext +PKG stdext +PKG threads +PKG unix +PKG xcp +PKG xcp-inventory +PKG xcp.network +PKG xcp.network +PKG xen-api-client From 95bef60b026997e23decdd4d9c2e0fa1e2da2c17 Mon Sep 17 00:00:00 2001 From: John Else Date: Fri, 25 Oct 2013 14:47:42 +0100 Subject: [PATCH 033/260] Remove http-svr dependency networkd has been using cohttp via xcp-idl since commit e6b2f0774b71683b4a970ce64c96e6d31f11e488 Signed-off-by: John Else --- xcp-networkd.obuild | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/xcp-networkd.obuild b/xcp-networkd.obuild index 5a413a820..8b0ff8195 100644 --- a/xcp-networkd.obuild +++ b/xcp-networkd.obuild @@ -13,7 +13,7 @@ library network-libs executable xcp-networkd main: networkd.ml src-dir: networkd - build-deps: threads, rpclib, rpclib.unix, forkexec, stdext, http-svr, xcp-inventory, network-libs, xen-api-client, xcp, xcp.network, netlink + build-deps: threads, rpclib, rpclib.unix, forkexec, stdext, xcp-inventory, network-libs, xen-api-client, xcp, xcp.network, netlink pp: camlp4o executable networkd_db From ba6ca5f38ae163c179d34ce344571cb33c635565 Mon Sep 17 00:00:00 2001 From: Ravi Kondamuru Date: Tue, 29 Oct 2013 16:45:44 +0000 Subject: [PATCH 034/260] CA-99828 Add a new bond option: lacp-fallback-ab lacp-fallback-ab allows lacp bond to fallback to active-backup when there is no lacp partner. Signed-off-by: Ravi Kondamuru --- lib/network_utils.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 0096fc768..7fa8bdc1e 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -751,7 +751,7 @@ module Ovs = struct let make_bond_properties name properties = let known_props = ["mode"; "hashing-algorithm"; "updelay"; "downdelay"; "miimon"; "use_carrier"; "rebalance-interval"; - "lacp-time"; "lacp-aggregation-key"] in + "lacp-time"; "lacp-aggregation-key"; "lacp-fallback-ab"] in let mode_args = let mode = if List.mem_assoc "mode" properties then List.assoc "mode" properties else "balance-slb" in @@ -795,7 +795,8 @@ module Ovs = struct "use_carrier", "other-config:bond-detect-mode"; "rebalance-interval", "other-config:bond-rebalance-interval";]) and extra_args = List.flatten (List.map get_prop - ["lacp-time", "other-config:lacp-time";]) + ["lacp-time", "other-config:lacp-time"; + "lacp-fallback-ab", "other-config:lacp-fallback-ab";]) and per_iface_args = List.flatten (List.map get_prop ["lacp-aggregation-key", "other-config:lacp-aggregation-key"; "lacp-actor-key", "other-config:lacp-actor-key";]) From f22a9dcf6d97b072cb0605626d14086bc178224d Mon Sep 17 00:00:00 2001 From: Andrew Cooper Date: Mon, 18 Nov 2013 14:26:58 +0000 Subject: [PATCH 035/260] CA-121503 - Make use of rc and stderr when appropriate. Signed-off-by: Andrew Cooper --- networkd_db/networkd_db.ml | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/networkd_db/networkd_db.ml b/networkd_db/networkd_db.ml index f96fcb76d..389937ad7 100644 --- a/networkd_db/networkd_db.ml +++ b/networkd_db/networkd_db.ml @@ -20,6 +20,7 @@ let name = "networkd_db" let _ = let bridge = ref "" in let iface = ref "" in + let rc = ref 0 in Arg.parse (Arg.align [ "-bridge", Arg.Set_string bridge, "Bridge name"; "-iface", Arg.Set_string iface, "Interface name"; @@ -35,7 +36,8 @@ let _ = let ifaces = List.flatten (List.map (fun (_, port) -> port.interfaces) bridge_config.ports) in Printf.printf "interfaces=%s\n" (String.concat "," ifaces) end else - print_endline ("Could not find bridge " ^ !bridge); + rc := 1; + Printf.fprintf stderr "Could not find bridge %s\n" !bridge; if !iface <> "" then if List.mem_assoc !iface config.interface_config then begin @@ -93,7 +95,8 @@ let _ = let data = datav4 @ datav6 in List.iter (fun (k, v) -> Printf.printf "%s=%s\n" k v) data end else - print_endline ("Could not find interface " ^ !iface); + rc := 1; + Printf.fprintf stderr "Could not find interface %s\n" !iface; with Network_config.Read_error -> - print_endline ("Failed to read " ^ name) - + Printf.fprintf stderr "Failed to read %s\n" name; + exit !rc; From 8966bd08449751adb20e3245fccac67de8edbae1 Mon Sep 17 00:00:00 2001 From: Andrew Cooper Date: Mon, 18 Nov 2013 14:49:40 +0000 Subject: [PATCH 036/260] Fix up tabs vs spaces --- networkd_db/networkd_db.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/networkd_db/networkd_db.ml b/networkd_db/networkd_db.ml index 389937ad7..33d5dfc71 100644 --- a/networkd_db/networkd_db.ml +++ b/networkd_db/networkd_db.ml @@ -20,7 +20,7 @@ let name = "networkd_db" let _ = let bridge = ref "" in let iface = ref "" in - let rc = ref 0 in + let rc = ref 0 in Arg.parse (Arg.align [ "-bridge", Arg.Set_string bridge, "Bridge name"; "-iface", Arg.Set_string iface, "Interface name"; From 2c7d0fa2166979644e03e20e3e27ea8812cffcc7 Mon Sep 17 00:00:00 2001 From: Andrew Cooper Date: Mon, 18 Nov 2013 15:14:54 +0000 Subject: [PATCH 037/260] Use begin/end blocks correctly. --- networkd_db/networkd_db.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/networkd_db/networkd_db.ml b/networkd_db/networkd_db.ml index 33d5dfc71..eb8ef08fa 100644 --- a/networkd_db/networkd_db.ml +++ b/networkd_db/networkd_db.ml @@ -35,10 +35,10 @@ let _ = let bridge_config = List.assoc !bridge config.bridge_config in let ifaces = List.flatten (List.map (fun (_, port) -> port.interfaces) bridge_config.ports) in Printf.printf "interfaces=%s\n" (String.concat "," ifaces) - end else + end else begin rc := 1; Printf.fprintf stderr "Could not find bridge %s\n" !bridge; - + end; if !iface <> "" then if List.mem_assoc !iface config.interface_config then begin let interface_config = List.assoc !iface config.interface_config in @@ -94,9 +94,10 @@ let _ = in let data = datav4 @ datav6 in List.iter (fun (k, v) -> Printf.printf "%s=%s\n" k v) data - end else + end else begin rc := 1; Printf.fprintf stderr "Could not find interface %s\n" !iface; + end; with Network_config.Read_error -> Printf.fprintf stderr "Failed to read %s\n" name; exit !rc; From 82031412fd8000a4de1dd03a43a6b38d676c233b Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Wed, 4 Dec 2013 14:40:43 +0000 Subject: [PATCH 038/260] add config file for network.conf to select the backend type Signed-off-by: Rob Hoes --- networkd/network_server.ml | 21 ++++++++++++--------- networkd/networkd.ml | 6 ++++++ 2 files changed, 18 insertions(+), 9 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index d0c2b1401..dbb7a31c6 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -24,6 +24,7 @@ open D type context = unit +let network_conf = ref "/etc/xcp/network.conf" let config : config_t ref = ref empty_config let legacy_management_interface_start () = @@ -396,15 +397,17 @@ module Bridge = struct config := {!config with bridge_config = update_config !config.bridge_config name data} let determine_backend () = - let backend = String.strip String.isspace - (Unixext.string_of_file ("/etc/xcp/network.conf")) in - match backend with - | "openvswitch" | "vswitch" -> kind := Openvswitch - | "bridge" -> kind := Bridge - | backend -> - let error = Printf.sprintf "ERROR: network backend unknown (%s)" backend in - debug "%s" error; - failwith error + try + let backend = String.strip String.isspace (Unixext.string_of_file !network_conf) in + match backend with + | "openvswitch" | "vswitch" -> kind := Openvswitch + | "bridge" -> kind := Bridge + | backend -> + warn "Network backend unknown (%s). Falling back to Open vSwitch." backend; + kind := Openvswitch + with _ -> + warn "Network-conf file not found. Falling back to Open vSwitch."; + kind := Openvswitch let get_bond_links_up _ dbg ~name = Debug.with_thread_associated dbg (fun () -> diff --git a/networkd/networkd.ml b/networkd/networkd.ml index f2d9762b7..a84680bb3 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -22,6 +22,12 @@ open D module Server = Network_interface.Server(Network_server) let resources = [ + { Xcp_service.name = "network-conf"; + description = "used to select the network backend"; + essential = true; + path = Network_server.network_conf; + perms = [ Unix.R_OK ]; + }; { Xcp_service.name = "brctl"; description = "used to set up bridges"; essential = true; From 404352cdadecf6e0a368c9e4172018d95e71b77c Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Wed, 4 Dec 2013 17:44:11 +0000 Subject: [PATCH 039/260] CA-120846: fix get_mac for bonded interfaces When an interface is bonded by the Linux bonding driver, the driver may change the MAC address of the interface to that of the bond. The only place where you can find the "real" MAC address of a bond slave seems to be /proc/net/bonding. Signed-off-by: Rob Hoes --- lib/network_utils.ml | 52 ++++++++++++++++++++++++++++---------- networkd/network_server.ml | 4 ++- 2 files changed, 41 insertions(+), 15 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 7fa8bdc1e..7021cc743 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -445,6 +445,12 @@ module Linux_bonding = struct error "Failed to remove slave %s from bond %s" slave master else error "Bond %s does not exist; cannot remove slave" master + + let get_bond_master_of slave = + try + let path = Unix.readlink (Sysfs.getpath slave "master") in + Some (List.hd (List.rev (String.split '/' path))) + with _ -> None end module Dhclient = struct @@ -533,28 +539,46 @@ module Sysctl = struct end module Proc = struct - let get_bond_links_up name = + let get_bond_slave_info name key = try let raw = Unixext.string_of_file (bonding_dir ^ name) in let lines = String.split '\n' raw in let check_lines lines = - let rec loop acc = function - | [] -> acc - | line1 :: line2 :: tail -> - if (String.startswith "Slave Interface:" line1) - && (String.startswith "MII Status:" line2) - && (String.endswith "up" line2) - then - loop (acc + 1) tail - else - loop acc (line2 :: tail) - | _ :: [] -> acc in - loop 0 lines in + let rec loop current acc = function + | [] -> acc + | line :: tail -> + try + Scanf.sscanf line "%s@: %s@\n" (fun k v -> + if k = "Slave Interface" then begin + let interface = Some (String.strip String.isspace v) in + loop interface acc tail + end else if k = key then + match current with + | Some interface -> loop current ((interface, String.strip String.isspace v) :: acc) tail + | None -> loop current acc tail + else + loop current acc tail + ) + with _ -> + loop current acc tail + in + loop None [] lines + in check_lines lines with e -> error "Error: could not read %s." (bonding_dir ^ name); - 0 + [] + let get_bond_slave_mac name slave = + let macs = get_bond_slave_info name "Permanent HW addr" in + if List.mem_assoc slave macs then + List.assoc slave macs + else + raise Not_found + + let get_bond_links_up name = + let statusses = get_bond_slave_info name "MII Status" in + List.fold_left (fun x (_, y) -> x + (if y = "up" then 1 else 0)) 0 statusses end module Ovs = struct diff --git a/networkd/network_server.ml b/networkd/network_server.ml index dbb7a31c6..5f10c9d70 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -103,7 +103,9 @@ module Interface = struct let get_mac _ dbg ~name = Debug.with_thread_associated dbg (fun () -> - Ip.get_mac name + match Linux_bonding.get_bond_master_of name with + | Some master -> Proc.get_bond_slave_mac master name + | None -> Ip.get_mac name ) () let is_up _ dbg ~name = From 6b7836dea07b06ebf734d8fe193dfde3e1788449 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Wed, 29 Jan 2014 14:49:49 +0000 Subject: [PATCH 040/260] CA-114498: Linux bonding: set properties (e.g. mode) before adding slaves This is needed to get LACP bonding to work on the Linux bridge backend. Signed-off-by: Rob Hoes --- networkd/network_server.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 5f10c9d70..911affe25 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -637,18 +637,18 @@ module Bridge = struct end else begin if not (List.mem name (Sysfs.bridge_to_interfaces bridge)) then begin Linux_bonding.add_bond_master name; - List.iter (fun name -> Interface.bring_down () dbg ~name) interfaces; - List.iter (Linux_bonding.add_bond_slave name) interfaces; - begin match bond_mac with - | Some mac -> Ip.set_mac name mac - | None -> warn "No MAC address specified for the bond" - end; let bond_properties = if List.mem_assoc "mode" bond_properties && List.assoc "mode" bond_properties = "lacp" then List.replace_assoc "mode" "802.3ad" bond_properties else bond_properties in - Linux_bonding.set_bond_properties name bond_properties + Linux_bonding.set_bond_properties name bond_properties; + List.iter (fun name -> Interface.bring_down () dbg ~name) interfaces; + List.iter (Linux_bonding.add_bond_slave name) interfaces; + begin match bond_mac with + | Some mac -> Ip.set_mac name mac + | None -> warn "No MAC address specified for the bond" + end end; Interface.bring_up () dbg ~name; ignore (Brctl.create_port bridge name) From ade5bba3dac934b1baf0ff33bd02dd7155f79fb8 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Thu, 30 Jan 2014 17:56:58 +0000 Subject: [PATCH 041/260] CA-118425/SCTX-1559: Remove interfaces from bridge before creating VLAN on it This avoids problems in case the bridge already existed for some reason, e.g. because it was not cleaned up due to an earlier error condition. Signed-off-by: Rob Hoes --- networkd/network_server.ml | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 911affe25..a8c2bb357 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -481,11 +481,23 @@ module Bridge = struct match vlan with | None -> () | Some (parent, vlan) -> - let interface = List.hd (List.filter (fun n -> + (* Robustness enhancement: ensure there are no other VLANs in the bridge *) + let current_interfaces = List.filter (fun n -> + String.startswith "eth" n || String.startswith "bond" n + ) (Sysfs.bridge_to_interfaces name) in + debug "Removing these non-VIF interfaces found on the bridge: %s" + (String.concat ", " current_interfaces); + List.iter (fun interface -> + Brctl.destroy_port name interface; + Interface.bring_down () dbg ~name:interface + ) current_interfaces; + + (* Now create the new VLAN device and add it to the bridge *) + let parent_interface = List.hd (List.filter (fun n -> String.startswith "eth" n || String.startswith "bond" n ) (Sysfs.bridge_to_interfaces parent)) in - Ip.create_vlan interface vlan; - let vlan_name = Ip.vlan_name interface vlan in + Ip.create_vlan parent_interface vlan; + let vlan_name = Ip.vlan_name parent_interface vlan in Interface.bring_up () dbg ~name:vlan_name; Brctl.create_port name vlan_name end; From 28cd274e89104caebdf4188a5b39bcdcef77fd60 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Wed, 7 May 2014 10:54:57 +0100 Subject: [PATCH 042/260] s/Stringext/Xstringext/g Signed-off-by: Jon Ludlam --- lib/network_config.ml | 2 +- lib/network_utils.ml | 2 +- networkd/network_monitor.ml | 2 +- networkd/network_monitor_thread.ml | 2 +- networkd/network_server.ml | 2 +- test/network_test_lacp_properties.ml | 4 ++-- 6 files changed, 7 insertions(+), 7 deletions(-) diff --git a/lib/network_config.ml b/lib/network_config.ml index 186a21127..2993e7513 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -15,7 +15,7 @@ open Network_interface open Fun -open Stringext +open Xstringext module D = Debug.Make(struct let name = "network_config" end) open D diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 7021cc743..90ab69791 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -13,7 +13,7 @@ *) open Listext -open Stringext +open Xstringext open Fun open Network_interface diff --git a/networkd/network_monitor.ml b/networkd/network_monitor.ml index 4e136840f..fc6921683 100644 --- a/networkd/network_monitor.ml +++ b/networkd/network_monitor.ml @@ -16,7 +16,7 @@ open Network_interface include Network_stats open Fun -open Stringext +open Xstringext open Threadext let write_stats stats = diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index f0b7d7fba..3a357b225 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -15,7 +15,7 @@ open Network_utils open Fun -open Stringext +open Xstringext open Listext open Threadext diff --git a/networkd/network_server.ml b/networkd/network_server.ml index a8c2bb357..5b7b96e59 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -16,7 +16,7 @@ open Network_utils open Network_interface open Fun -open Stringext +open Xstringext open Listext module D = Debug.Make(struct let name = "network_server" end) diff --git a/test/network_test_lacp_properties.ml b/test/network_test_lacp_properties.ml index a07b5f0c6..0ed52f626 100644 --- a/test/network_test_lacp_properties.ml +++ b/test/network_test_lacp_properties.ml @@ -91,7 +91,7 @@ let test_lacp_aggregation_key_vsctl arg () = skip_if true "Unimplemented" ; print_endline answer ; assert_bool "lacp_aggregation_key is passed to ovs-vsctl command" (List.exists - (fun s -> (Stringext.String.(strip isspace s) == answer)) + (fun s -> (Xstringext.String.(strip isspace s) == answer)) !OVS_Cli_test.vsctl_output) (* Test case for bond_create with default lacp-{time,aggregation-key} settings. @@ -115,7 +115,7 @@ let test_lacp_defaults_bond_create () = List.iter (fun arg -> assert_bool "key=value argument pairs can't have missing values" - (let open Stringext.String in + (let open Xstringext.String in arg |> strip isspace |> endswith "=" |> not)) !OVS_Cli_test.vsctl_output From 881298ed286fd1d31e53219d7729017d7725e5e2 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Tue, 3 Jun 2014 18:33:50 +0100 Subject: [PATCH 043/260] Release 0.9.4 Signed-off-by: Jon Ludlam --- ChangeLog | 10 + Makefile | 30 +- _oasis | 47 + _tags | 89 + lib/META | 18 +- lib/libnetworklibs_stubs.clib | 4 + lib/networklibs.mldylib | 5 + lib/networklibs.mllib | 5 + myocamlbuild.ml | 625 +++ networkd/network_server.ml | 2 +- setup.ml | 7052 +++++++++++++++++++++++++++++++++ 11 files changed, 7869 insertions(+), 18 deletions(-) create mode 100644 _oasis create mode 100644 _tags create mode 100644 lib/libnetworklibs_stubs.clib create mode 100644 lib/networklibs.mldylib create mode 100644 lib/networklibs.mllib create mode 100644 myocamlbuild.ml create mode 100644 setup.ml diff --git a/ChangeLog b/ChangeLog index d066396a8..2731b252a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +0.9.4 (3-Jun-2014): +* Use oasis for building +* Update to new stdext interface +* Fix CA-118425/SCTX-1559: An earlier error could cause problems with VLANs +* Enable LACP bonding on linux bridge +* Fix CA-116420: Bonds were getting incorrect MAC addresses on 3.x kernels +* Fix CA-120846: Finding MAC addresses for bonds +* Fix CA-105789: Bridge had incorrect MAC address on first boot +* Fix CA-121503: Pay attention to return codes from subprocesses (Andrew Cooper) + 0.9.3 (24-Sep-2013): * Allow the Bond.create to carry on even if the MTU size is invalid * network monitor: better represent duplex mode for NIC bonds diff --git a/Makefile b/Makefile index e449a9e64..819ea638e 100644 --- a/Makefile +++ b/Makefile @@ -1,23 +1,37 @@ BINDIR ?= /usr/bin SBINDIR ?= /usr/sbin ETCDIR ?= /etc +all: build doc .PHONY: test install uninstall clean -dist/build/xcp-networkd/xcp-networkd: - obuild configure --enable-tests - obuild build +export OCAMLRUNPARAM=b +J=4 -test: - obuild test --output +setup.bin: setup.ml + @ocamlopt.opt -o $@ $< || ocamlopt -o $@ $< || ocamlc -o $@ $< + @rm -f setup.cmx setup.cmi setup.o setup.cmo + +setup.data: setup.bin + @./setup.bin -configure --enable-tests + +build: setup.data setup.bin + @./setup.bin -build -j $(J) + +doc: setup.data setup.bin + @./setup.bin -doc -j $(J) + +test: setup.bin build + @./setup.bin -test install: - install -D dist/build/xcp-networkd/xcp-networkd $(DESTDIR)$(SBINDIR)/xcp-networkd - install -D dist/build/networkd_db/networkd_db $(DESTDIR)$(BINDIR)/networkd_db + install -D networkd.native $(DESTDIR)$(SBINDIR)/xcp-networkd + install -D networkd_db.native $(DESTDIR)$(BINDIR)/networkd_db uninstall: rm -f $(DESTDIR)$(SBINDIR)/xcp-networkd rm -f $(DESTDIR)$(SBINDIR)/networkd_db clean: - rm -rf dist + @ocamlbuild -clean + @rm -f setup.data setup.log setup.bin diff --git a/_oasis b/_oasis new file mode 100644 index 000000000..bf17b223b --- /dev/null +++ b/_oasis @@ -0,0 +1,47 @@ +OASISFormat: 0.3 +Name: xcp-networkd +Version: 0.9.4 +Synopsis: XCP Network Daemon +Authors: Rob Hoes +License: LGPL-2.1 with OCaml linking exception +Plugins: META (0.2) +BuildTools: ocamlbuild + +Library networklibs + CompiledObject: best + Path: lib + Findlibname: network-libs + Modules: Network_config, Network_utils + BuildDepends: forkexec, stdext, threads, rpclib, stdext, xcp-inventory, xcp.network + CSources: link_stubs.c, netdev.h + CCOpt: -Wno-unused-function -g -ggdb + +Executable xcp_networkd + CompiledObject: best + Path: networkd + MainIs: networkd.ml + Custom: true + Install: false + BuildDepends: threads, rpclib, rpclib.unix, forkexec, stdext, xcp-inventory, network-libs, xen-api-client, xcp, xcp.network + +Executable networkd_db + CompiledObject: best + Path: networkd_db + MainIs: networkd_db.ml + Custom: true + Install: false + BuildDepends: network-libs, stdext, threads, xcp.network + +Executable network_test + CompiledObject: best + Path: test + MainIs: network_test.ml + Install: false + BuildDepends: stdext, oUnit, network-libs + +Test test_networkd + Run$: flag(tests) + Command: $network_test + WorkingDirectory: . + + diff --git a/_tags b/_tags new file mode 100644 index 000000000..34f629423 --- /dev/null +++ b/_tags @@ -0,0 +1,89 @@ +# OASIS_START +# DO NOT EDIT (digest: 6dce1a9a50f608514e51caf58ef0ebc9) +# 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 +<**/.svn>: -traverse +<**/.svn>: not_hygienic +".bzr": -traverse +".bzr": not_hygienic +".hg": -traverse +".hg": not_hygienic +".git": -traverse +".git": not_hygienic +"_darcs": -traverse +"_darcs": not_hygienic +# Library networklibs +"lib/networklibs.cmxs": use_networklibs +: oasis_library_networklibs_ccopt +"lib/link_stubs.c": oasis_library_networklibs_ccopt +: use_libnetworklibs_stubs +: pkg_forkexec +: pkg_rpclib +: pkg_stdext +: pkg_threads +: pkg_xcp-inventory +: pkg_xcp.network +"lib/link_stubs.c": pkg_forkexec +"lib/link_stubs.c": pkg_rpclib +"lib/link_stubs.c": pkg_stdext +"lib/link_stubs.c": pkg_threads +"lib/link_stubs.c": pkg_xcp-inventory +"lib/link_stubs.c": pkg_xcp.network +# Executable xcp_networkd +: pkg_forkexec +: pkg_rpclib +: pkg_rpclib.unix +: pkg_stdext +: pkg_threads +: pkg_xcp +: pkg_xcp-inventory +: pkg_xcp.network +: pkg_xen-api-client +: use_networklibs +: pkg_forkexec +: pkg_rpclib +: pkg_rpclib.unix +: pkg_stdext +: pkg_threads +: pkg_xcp +: pkg_xcp-inventory +: pkg_xcp.network +: pkg_xen-api-client +: use_networklibs +: custom +# Executable networkd_db +: pkg_forkexec +: pkg_rpclib +: pkg_stdext +: pkg_threads +: pkg_xcp-inventory +: pkg_xcp.network +: use_networklibs +: pkg_forkexec +: pkg_rpclib +: pkg_stdext +: pkg_threads +: pkg_xcp-inventory +: pkg_xcp.network +: use_networklibs +: custom +# Executable network_test +: pkg_forkexec +: pkg_oUnit +: pkg_rpclib +: pkg_stdext +: pkg_threads +: pkg_xcp-inventory +: pkg_xcp.network +: use_networklibs +: pkg_forkexec +: pkg_oUnit +: pkg_rpclib +: pkg_stdext +: pkg_threads +: pkg_xcp-inventory +: pkg_xcp.network +: use_networklibs +# OASIS_STOP + diff --git a/lib/META b/lib/META index c73201d12..c6a36cffc 100644 --- a/lib/META +++ b/lib/META @@ -1,12 +1,12 @@ # OASIS_START -# DO NOT EDIT (digest: 5476962f222c44a9e65ebd154950f9cc) -version = "0.1.0" -description = "The XCP networking daemon" -requires = "threads rpclib log stdext xcp-inventory xcp.network" -archive(byte) = "xcp-networkd.cma" -archive(byte, plugin) = "xcp-networkd.cma" -archive(native) = "xcp-networkd.cmxa" -archive(native, plugin) = "xcp-networkd.cmxs" -exists_if = "xcp-networkd.cma" +# DO NOT EDIT (digest: 91b748c7a2332c0932eed83315151278) +version = "0.9.4" +description = "XCP Network Daemon" +requires = "forkexec stdext threads rpclib stdext xcp-inventory xcp.network" +archive(byte) = "networklibs.cma" +archive(byte, plugin) = "networklibs.cma" +archive(native) = "networklibs.cmxa" +archive(native, plugin) = "networklibs.cmxs" +exists_if = "networklibs.cma" # OASIS_STOP diff --git a/lib/libnetworklibs_stubs.clib b/lib/libnetworklibs_stubs.clib new file mode 100644 index 000000000..4af8b9516 --- /dev/null +++ b/lib/libnetworklibs_stubs.clib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 2eec6769d0c3db5ab2748de2ec73c768) +link_stubs.o +# OASIS_STOP diff --git a/lib/networklibs.mldylib b/lib/networklibs.mldylib new file mode 100644 index 000000000..465d4b7bd --- /dev/null +++ b/lib/networklibs.mldylib @@ -0,0 +1,5 @@ +# OASIS_START +# DO NOT EDIT (digest: 769536bab5c8cdff920a6b9ddafec2e2) +Network_config +Network_utils +# OASIS_STOP diff --git a/lib/networklibs.mllib b/lib/networklibs.mllib new file mode 100644 index 000000000..465d4b7bd --- /dev/null +++ b/lib/networklibs.mllib @@ -0,0 +1,5 @@ +# OASIS_START +# DO NOT EDIT (digest: 769536bab5c8cdff920a6b9ddafec2e2) +Network_config +Network_utils +# OASIS_STOP diff --git a/myocamlbuild.ml b/myocamlbuild.ml new file mode 100644 index 000000000..8ec5d77b9 --- /dev/null +++ b/myocamlbuild.ml @@ -0,0 +1,625 @@ +(* OASIS_START *) +(* DO NOT EDIT (digest: 1b562e89c2fc3873269cda485f3abe87) *) +module OASISGettext = struct +(* # 22 "src/oasis/OASISGettext.ml" *) + + + let ns_ str = + str + + + let s_ str = + str + + + let f_ (str: ('a, 'b, 'c, 'd) format4) = + str + + + let fn_ fmt1 fmt2 n = + if n = 1 then + fmt1^^"" + else + fmt2^^"" + + + let init = + [] + + +end + +module OASISExpr = struct +(* # 22 "src/oasis/OASISExpr.ml" *) + + + + + + open OASISGettext + + + type test = string + + + type flag = string + + + type t = + | EBool of bool + | ENot of t + | EAnd of t * t + | EOr of t * t + | EFlag of flag + | ETest of test * string + + + + type 'a choices = (t * 'a) list + + + let eval var_get t = + let rec eval' = + function + | EBool b -> + b + + | ENot e -> + not (eval' e) + + | EAnd (e1, e2) -> + (eval' e1) && (eval' e2) + + | EOr (e1, e2) -> + (eval' e1) || (eval' e2) + + | EFlag nm -> + let v = + var_get nm + in + assert(v = "true" || v = "false"); + (v = "true") + + | ETest (nm, vl) -> + let v = + var_get nm + in + (v = vl) + in + eval' t + + + let choose ?printer ?name var_get lst = + let rec choose_aux = + function + | (cond, vl) :: tl -> + if eval var_get cond then + vl + else + choose_aux tl + | [] -> + let str_lst = + if lst = [] then + s_ "" + else + String.concat + (s_ ", ") + (List.map + (fun (cond, vl) -> + match printer with + | Some p -> p vl + | None -> s_ "") + lst) + in + match name with + | Some nm -> + failwith + (Printf.sprintf + (f_ "No result for the choice list '%s': %s") + nm str_lst) + | None -> + failwith + (Printf.sprintf + (f_ "No result for a choice list: %s") + str_lst) + in + choose_aux (List.rev lst) + + +end + + +# 132 "myocamlbuild.ml" +module BaseEnvLight = struct +(* # 22 "src/base/BaseEnvLight.ml" *) + + + module MapString = Map.Make(String) + + + type t = string MapString.t + + + let default_filename = + Filename.concat + (Sys.getcwd ()) + "setup.data" + + + let load ?(allow_empty=false) ?(filename=default_filename) () = + if Sys.file_exists filename then + begin + let chn = + open_in_bin filename + in + let st = + Stream.of_channel chn + in + let line = + ref 1 + in + let st_line = + Stream.from + (fun _ -> + try + match Stream.next st with + | '\n' -> incr line; Some '\n' + | c -> Some c + with Stream.Failure -> None) + in + let lexer = + Genlex.make_lexer ["="] st_line + in + let rec read_file mp = + match Stream.npeek 3 lexer with + | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> + Stream.junk lexer; + Stream.junk lexer; + Stream.junk lexer; + read_file (MapString.add nm value mp) + | [] -> + mp + | _ -> + failwith + (Printf.sprintf + "Malformed data file '%s' line %d" + filename !line) + in + let mp = + read_file MapString.empty + in + close_in chn; + mp + end + else if allow_empty then + begin + MapString.empty + end + else + begin + failwith + (Printf.sprintf + "Unable to load environment, the file '%s' doesn't exist." + filename) + end + + + let rec var_expand str env = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) env + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + + + let var_get name env = + var_expand (MapString.find name env) env + + + let var_choose lst env = + OASISExpr.choose + (fun nm -> var_get nm env) + lst +end + + +# 237 "myocamlbuild.ml" +module MyOCamlbuildFindlib = struct +(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) + + + (** OCamlbuild extension, copied from + * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild + * by N. Pouillard and others + * + * Updated on 2009/02/28 + * + * Modified by Sylvain Le Gall + *) + open Ocamlbuild_plugin + + + (* these functions are not really officially exported *) + let run_and_read = + Ocamlbuild_pack.My_unix.run_and_read + + + let blank_sep_strings = + Ocamlbuild_pack.Lexers.blank_sep_strings + + + let exec_from_conf exec = + let exec = + let env_filename = Pathname.basename BaseEnvLight.default_filename in + let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in + try + BaseEnvLight.var_get exec env + with Not_found -> + Printf.eprintf "W: Cannot get variable %s\n" exec; + exec + in + let fix_win32 str = + if Sys.os_type = "Win32" then begin + let buff = Buffer.create (String.length str) in + (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. + *) + String.iter + (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) + str; + Buffer.contents buff + end else begin + str + end + in + fix_win32 exec + + let split s ch = + let buf = Buffer.create 13 in + let x = ref [] in + let flush () = + x := (Buffer.contents buf) :: !x; + Buffer.clear buf + in + 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' + + + let before_space s = + try + String.before s (String.index s ' ') + with Not_found -> s + + (* ocamlfind command *) + let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] + + (* This lists all supported packages. *) + let find_packages () = + List.map before_space (split_nl & run_and_read "ocamlfind list") + + + (* Mock to list available syntaxes. *) + let find_syntaxes () = ["camlp4o"; "camlp4r"] + + + let well_known_syntax = [ + "camlp4.quotations.o"; + "camlp4.quotations.r"; + "camlp4.exceptiontracer"; + "camlp4.extend"; + "camlp4.foldgenerator"; + "camlp4.listcomprehension"; + "camlp4.locationstripper"; + "camlp4.macro"; + "camlp4.mapgenerator"; + "camlp4.metagenerator"; + "camlp4.profiler"; + "camlp4.tracer" + ] + + + let dispatch = + function + | After_options -> + (* By using Before_options one let command line options have an higher + * priority on the contrary using After_options will guarantee to have + * the higher priority override default commands by ocamlfind ones *) + Options.ocamlc := ocamlfind & A"ocamlc"; + Options.ocamlopt := ocamlfind & A"ocamlopt"; + Options.ocamldep := ocamlfind & A"ocamldep"; + Options.ocamldoc := ocamlfind & A"ocamldoc"; + Options.ocamlmktop := ocamlfind & A"ocamlmktop"; + Options.ocamlmklib := ocamlfind & A"ocamlmklib" + + | After_rules -> + + (* When one link an OCaml library/binary/package, one should use + * -linkpkg *) + flag ["ocaml"; "link"; "program"] & 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 + (* TODO: consider how to really choose camlp4o or camlp4r. *) + 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" || + List.mem pkg well_known_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 ()); + + (* Like -package but for extensions syntax. Morover -syntax is useless + * when linking. *) + List.iter begin fun syntax -> + flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & + S[A"-syntax"; A syntax]; + end (find_syntaxes ()); + + (* The default "thread" tag is not compatible with ocamlfind. + * Indeed, the default rules add the "threads.cma" or "threads.cmxa" + * options when using this tag. When using the "-linkpkg" option with + * ocamlfind, this module will then be added twice on the command line. + * + * To solve this, one approach is to add the "-thread" option when using + * the "threads" package using the previous plugin. + *) + flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); + flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); + flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); + flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); + flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); + + | _ -> + () +end + +module MyOCamlbuildBase = struct +(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) + + + (** Base functions for writing myocamlbuild.ml + @author Sylvain Le Gall + *) + + + + + + open Ocamlbuild_plugin + module OC = Ocamlbuild_pack.Ocaml_compiler + + + type dir = string + type file = string + type name = string + type tag = string + + +(* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) + + + type t = + { + lib_ocaml: (name * dir list * string list) list; + lib_c: (name * dir * file list) list; + flags: (tag list * (spec OASISExpr.choices)) list; + (* Replace the 'dir: include' from _tags by a precise interdepends in + * directory. + *) + includes: (dir * dir list) list; + } + + + let env_filename = + Pathname.basename + BaseEnvLight.default_filename + + + let dispatch_combine lst = + fun e -> + List.iter + (fun dispatch -> dispatch e) + lst + + + let tag_libstubs nm = + "use_lib"^nm^"_stubs" + + + let nm_libstubs nm = + nm^"_stubs" + + + let dispatch t e = + let env = + BaseEnvLight.load + ~filename:env_filename + ~allow_empty:true + () + in + match e with + | Before_options -> + let no_trailing_dot s = + if String.length s >= 1 && s.[0] = '.' then + String.sub s 1 ((String.length s) - 1) + else + s + in + List.iter + (fun (opt, var) -> + try + opt := no_trailing_dot (BaseEnvLight.var_get var env) + with Not_found -> + Printf.eprintf "W: Cannot get variable %s\n" var) + [ + Options.ext_obj, "ext_obj"; + Options.ext_lib, "ext_lib"; + Options.ext_dll, "ext_dll"; + ] + + | After_rules -> + (* Declare OCaml libraries *) + List.iter + (function + | nm, [], intf_modules -> + ocaml_lib nm; + let cmis = + List.map (fun m -> (String.uncapitalize m) ^ ".cmi") + intf_modules in + dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis + | nm, dir :: tl, intf_modules -> + ocaml_lib ~dir:dir (dir^"/"^nm); + List.iter + (fun dir -> + List.iter + (fun str -> + flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) + ["compile"; "infer_interface"; "doc"]) + tl; + let cmis = + List.map (fun m -> dir^"/"^(String.uncapitalize m)^".cmi") + intf_modules in + dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] + cmis) + t.lib_ocaml; + + (* Declare directories dependencies, replace "include" in _tags. *) + List.iter + (fun (dir, include_dirs) -> + Pathname.define_context dir include_dirs) + t.includes; + + (* Declare C libraries *) + List.iter + (fun (lib, dir, headers) -> + (* Handle C part of library *) + flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] + (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; + A("-l"^(nm_libstubs lib))]); + + flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] + (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); + + flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] + (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); + + (* When ocaml link something that use the C library, then one + need that file to be up to date. + *) + dep ["link"; "ocaml"; "program"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + + dep ["compile"; "ocaml"; "program"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + + (* TODO: be more specific about what depends on headers *) + (* Depends on .h files *) + dep ["compile"; "c"] + headers; + + (* Setup search path for lib *) + flag ["link"; "ocaml"; "use_"^lib] + (S[A"-I"; P(dir)]); + ) + t.lib_c; + + (* Add flags *) + List.iter + (fun (tags, cond_specs) -> + let spec = BaseEnvLight.var_choose cond_specs env in + let rec eval_specs = + function + | S lst -> S (List.map eval_specs lst) + | A str -> A (BaseEnvLight.var_expand str env) + | spec -> spec + in + flag tags & (eval_specs spec)) + t.flags + | _ -> + () + + + let dispatch_default t = + dispatch_combine + [ + dispatch t; + MyOCamlbuildFindlib.dispatch; + ] + + +end + + +# 594 "myocamlbuild.ml" +open Ocamlbuild_plugin;; +let package_default = + { + MyOCamlbuildBase.lib_ocaml = [("networklibs", ["lib"], [])]; + lib_c = [("networklibs", "lib", ["lib/netdev.h"])]; + flags = + [ + (["oasis_library_networklibs_ccopt"; "compile"], + [ + (OASISExpr.EBool true, + S + [ + A "-ccopt"; + A "-Wno-unused-function"; + A "-ccopt"; + A "-g"; + A "-ccopt"; + A "-ggdb" + ]) + ]) + ]; + includes = + [("test", ["lib"]); ("networkd_db", ["lib"]); ("networkd", ["lib"])] + } + ;; + +let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; + +# 624 "myocamlbuild.ml" +(* OASIS_STOP *) +Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 5b7b96e59..969413d3c 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -431,7 +431,7 @@ module Bridge = struct | None -> "" | Some (parent, vlan) -> Printf.sprintf " (VLAN %d on bridge %s)" vlan parent ); - update_config name {get_config name with vlan; bridge_mac=mac; other_config}; + update_config name {(get_config name) with vlan; bridge_mac=mac; other_config}; begin match !kind with | Openvswitch -> let fail_mode = diff --git a/setup.ml b/setup.ml new file mode 100644 index 000000000..c274d211b --- /dev/null +++ b/setup.ml @@ -0,0 +1,7052 @@ +(* setup.ml generated for the first time by OASIS v0.4.4 *) + +(* OASIS_START *) +(* DO NOT EDIT (digest: 8a544e6f7b2bc3fb2f97d5be41f7b1aa) *) +(* + Regenerated by OASIS v0.4.4 + Visit http://oasis.forge.ocamlcore.org for more information and + documentation about functions used in this file. +*) +module OASISGettext = struct +(* # 22 "src/oasis/OASISGettext.ml" *) + + + let ns_ str = + str + + + let s_ str = + str + + + let f_ (str: ('a, 'b, 'c, 'd) format4) = + str + + + let fn_ fmt1 fmt2 n = + if n = 1 then + fmt1^^"" + else + fmt2^^"" + + + let init = + [] + + +end + +module OASISContext = struct +(* # 22 "src/oasis/OASISContext.ml" *) + + + open OASISGettext + + + type level = + [ `Debug + | `Info + | `Warning + | `Error] + + + type t = + { + (* TODO: replace this by a proplist. *) + quiet: bool; + info: bool; + debug: bool; + ignore_plugins: bool; + ignore_unknown_fields: bool; + printf: level -> string -> unit; + } + + + let printf lvl str = + let beg = + match lvl with + | `Error -> s_ "E: " + | `Warning -> s_ "W: " + | `Info -> s_ "I: " + | `Debug -> s_ "D: " + in + prerr_endline (beg^str) + + + let default = + ref + { + quiet = false; + info = false; + debug = false; + ignore_plugins = false; + ignore_unknown_fields = false; + printf = printf; + } + + + let quiet = + {!default with quiet = true} + + + let fspecs () = + (* TODO: don't act on default. *) + let ignore_plugins = ref false in + ["-quiet", + Arg.Unit (fun () -> default := {!default with quiet = true}), + s_ " Run quietly"; + + "-info", + Arg.Unit (fun () -> default := {!default with info = true}), + s_ " Display information message"; + + + "-debug", + Arg.Unit (fun () -> default := {!default with debug = true}), + s_ " Output debug message"; + + "-ignore-plugins", + Arg.Set ignore_plugins, + s_ " Ignore plugin's field."; + + "-C", + (* TODO: remove this chdir. *) + Arg.String (fun str -> Sys.chdir str), + s_ "dir Change directory before running."], + fun () -> {!default with ignore_plugins = !ignore_plugins} +end + +module OASISString = struct +(* # 22 "src/oasis/OASISString.ml" *) + + + (** Various string utilities. + + Mostly inspired by extlib and batteries ExtString and BatString libraries. + + @author Sylvain Le Gall + *) + + + let nsplitf str f = + if str = "" then + [] + else + let buf = Buffer.create 13 in + let lst = ref [] in + let push () = + lst := Buffer.contents buf :: !lst; + Buffer.clear buf + in + let str_len = String.length str in + for i = 0 to str_len - 1 do + if f str.[i] then + push () + else + Buffer.add_char buf str.[i] + done; + push (); + List.rev !lst + + + (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the + separator. + *) + let nsplit str c = + nsplitf str ((=) c) + + + let find ~what ?(offset=0) str = + let what_idx = ref 0 in + let str_idx = ref offset in + while !str_idx < String.length str && + !what_idx < String.length what do + if str.[!str_idx] = what.[!what_idx] then + incr what_idx + else + what_idx := 0; + incr str_idx + done; + if !what_idx <> String.length what then + raise Not_found + else + !str_idx - !what_idx + + + let sub_start str len = + let str_len = String.length str in + if len >= str_len then + "" + else + String.sub str len (str_len - len) + + + let sub_end ?(offset=0) str len = + let str_len = String.length str in + if len >= str_len then + "" + else + String.sub str 0 (str_len - len) + + + let starts_with ~what ?(offset=0) str = + let what_idx = ref 0 in + let str_idx = ref offset in + let ok = ref true in + while !ok && + !str_idx < String.length str && + !what_idx < String.length what do + if str.[!str_idx] = what.[!what_idx] then + incr what_idx + else + ok := false; + incr str_idx + done; + if !what_idx = String.length what then + true + else + false + + + let strip_starts_with ~what str = + if starts_with ~what str then + sub_start str (String.length what) + else + raise Not_found + + + let ends_with ~what ?(offset=0) str = + let what_idx = ref ((String.length what) - 1) in + let str_idx = ref ((String.length str) - 1) in + let ok = ref true in + while !ok && + offset <= !str_idx && + 0 <= !what_idx do + if str.[!str_idx] = what.[!what_idx] then + decr what_idx + else + ok := false; + decr str_idx + done; + if !what_idx = -1 then + true + else + false + + + let strip_ends_with ~what str = + if ends_with ~what str then + sub_end str (String.length what) + else + raise Not_found + + + let replace_chars f s = + let buf = String.make (String.length s) 'X' in + for i = 0 to String.length s - 1 do + buf.[i] <- f s.[i] + done; + buf + + +end + +module OASISUtils = struct +(* # 22 "src/oasis/OASISUtils.ml" *) + + + open OASISGettext + + + module MapExt = + struct + module type S = + sig + include Map.S + val add_list: 'a t -> (key * 'a) list -> 'a t + val of_list: (key * 'a) list -> 'a t + val to_list: 'a t -> (key * 'a) list + end + + module Make (Ord: Map.OrderedType) = + struct + include Map.Make(Ord) + + let rec add_list t = + function + | (k, v) :: tl -> add_list (add k v t) tl + | [] -> t + + let of_list lst = add_list empty lst + + let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] + end + end + + + module MapString = MapExt.Make(String) + + + module SetExt = + struct + module type S = + sig + include Set.S + val add_list: t -> elt list -> t + val of_list: elt list -> t + val to_list: t -> elt list + end + + module Make (Ord: Set.OrderedType) = + struct + include Set.Make(Ord) + + let rec add_list t = + function + | e :: tl -> add_list (add e t) tl + | [] -> t + + let of_list lst = add_list empty lst + + let to_list = elements + end + end + + + module SetString = SetExt.Make(String) + + + let compare_csl s1 s2 = + String.compare (String.lowercase s1) (String.lowercase s2) + + + module HashStringCsl = + Hashtbl.Make + (struct + type t = string + + let equal s1 s2 = + (String.lowercase s1) = (String.lowercase s2) + + let hash s = + Hashtbl.hash (String.lowercase s) + end) + + module SetStringCsl = + SetExt.Make + (struct + type t = string + let compare = compare_csl + end) + + + let varname_of_string ?(hyphen='_') s = + if String.length s = 0 then + begin + invalid_arg "varname_of_string" + end + else + begin + let buf = + OASISString.replace_chars + (fun c -> + if ('a' <= c && c <= 'z') + || + ('A' <= c && c <= 'Z') + || + ('0' <= c && c <= '9') then + c + else + hyphen) + s; + in + let buf = + (* Start with a _ if digit *) + if '0' <= s.[0] && s.[0] <= '9' then + "_"^buf + else + buf + in + String.lowercase buf + end + + + let varname_concat ?(hyphen='_') p s = + let what = String.make 1 hyphen in + let p = + try + OASISString.strip_ends_with ~what p + with Not_found -> + p + in + let s = + try + OASISString.strip_starts_with ~what s + with Not_found -> + s + in + p^what^s + + + let is_varname str = + str = varname_of_string str + + + let failwithf fmt = Printf.ksprintf failwith fmt + + +end + +module PropList = struct +(* # 22 "src/oasis/PropList.ml" *) + + + open OASISGettext + + + type name = string + + + exception Not_set of name * string option + exception No_printer of name + exception Unknown_field of name * name + + + let () = + Printexc.register_printer + (function + | Not_set (nm, Some rsn) -> + Some + (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) + | Not_set (nm, None) -> + Some + (Printf.sprintf (f_ "Field '%s' is not set") nm) + | No_printer nm -> + Some + (Printf.sprintf (f_ "No default printer for value %s") nm) + | Unknown_field (nm, schm) -> + Some + (Printf.sprintf + (f_ "Field %s is not defined in schema %s") nm schm) + | _ -> + None) + + + module Data = + struct + type t = + (name, unit -> unit) Hashtbl.t + + let create () = + Hashtbl.create 13 + + let clear t = + Hashtbl.clear t + + +(* # 78 "src/oasis/PropList.ml" *) + end + + + module Schema = + struct + type ('ctxt, 'extra) value = + { + get: Data.t -> string; + set: Data.t -> ?context:'ctxt -> string -> unit; + help: (unit -> string) option; + extra: 'extra; + } + + type ('ctxt, 'extra) t = + { + name: name; + fields: (name, ('ctxt, 'extra) value) Hashtbl.t; + order: name Queue.t; + name_norm: string -> string; + } + + let create ?(case_insensitive=false) nm = + { + name = nm; + fields = Hashtbl.create 13; + order = Queue.create (); + name_norm = + (if case_insensitive then + String.lowercase + else + fun s -> s); + } + + let add t nm set get extra help = + let key = + t.name_norm nm + in + + if Hashtbl.mem t.fields key then + failwith + (Printf.sprintf + (f_ "Field '%s' is already defined in schema '%s'") + nm t.name); + Hashtbl.add + t.fields + key + { + set = set; + get = get; + help = help; + extra = extra; + }; + Queue.add nm t.order + + let mem t nm = + Hashtbl.mem t.fields nm + + let find t nm = + try + Hashtbl.find t.fields (t.name_norm nm) + with Not_found -> + raise (Unknown_field (nm, t.name)) + + let get t data nm = + (find t nm).get data + + let set t data nm ?context x = + (find t nm).set + data + ?context + x + + let fold f acc t = + Queue.fold + (fun acc k -> + let v = + find t k + in + f acc k v.extra v.help) + acc + t.order + + let iter f t = + fold + (fun () -> f) + () + t + + let name t = + t.name + end + + + module Field = + struct + type ('ctxt, 'value, 'extra) t = + { + set: Data.t -> ?context:'ctxt -> 'value -> unit; + get: Data.t -> 'value; + sets: Data.t -> ?context:'ctxt -> string -> unit; + gets: Data.t -> string; + help: (unit -> string) option; + extra: 'extra; + } + + let new_id = + let last_id = + ref 0 + in + fun () -> incr last_id; !last_id + + let create ?schema ?name ?parse ?print ?default ?update ?help extra = + (* Default value container *) + let v = + ref None + in + + (* If name is not given, create unique one *) + let nm = + match name with + | Some s -> s + | None -> Printf.sprintf "_anon_%d" (new_id ()) + in + + (* Last chance to get a value: the default *) + let default () = + match default with + | Some d -> d + | None -> raise (Not_set (nm, Some (s_ "no default value"))) + in + + (* Get data *) + let get data = + (* Get value *) + try + (Hashtbl.find data nm) (); + match !v with + | Some x -> x + | None -> default () + with Not_found -> + default () + in + + (* Set data *) + let set data ?context x = + let x = + match update with + | Some f -> + begin + try + f ?context (get data) x + with Not_set _ -> + x + end + | None -> + x + in + Hashtbl.replace + data + nm + (fun () -> v := Some x) + in + + (* Parse string value, if possible *) + let parse = + match parse with + | Some f -> + f + | None -> + fun ?context s -> + failwith + (Printf.sprintf + (f_ "Cannot parse field '%s' when setting value %S") + nm + s) + in + + (* Set data, from string *) + let sets data ?context s = + set ?context data (parse ?context s) + in + + (* Output value as string, if possible *) + let print = + match print with + | Some f -> + f + | None -> + fun _ -> raise (No_printer nm) + in + + (* Get data, as a string *) + let gets data = + print (get data) + in + + begin + match schema with + | Some t -> + Schema.add t nm sets gets extra help + | None -> + () + end; + + { + set = set; + get = get; + sets = sets; + gets = gets; + help = help; + extra = extra; + } + + let fset data t ?context x = + t.set data ?context x + + let fget data t = + t.get data + + let fsets data t ?context s = + t.sets data ?context s + + let fgets data t = + t.gets data + end + + + module FieldRO = + struct + let create ?schema ?name ?parse ?print ?default ?update ?help extra = + let fld = + Field.create ?schema ?name ?parse ?print ?default ?update ?help extra + in + fun data -> Field.fget data fld + end +end + +module OASISMessage = struct +(* # 22 "src/oasis/OASISMessage.ml" *) + + + open OASISGettext + open OASISContext + + + let generic_message ~ctxt lvl fmt = + let cond = + if ctxt.quiet then + false + else + match lvl with + | `Debug -> ctxt.debug + | `Info -> ctxt.info + | _ -> true + in + Printf.ksprintf + (fun str -> + if cond then + begin + ctxt.printf lvl str + end) + fmt + + + let debug ~ctxt fmt = + generic_message ~ctxt `Debug fmt + + + let info ~ctxt fmt = + generic_message ~ctxt `Info fmt + + + let warning ~ctxt fmt = + generic_message ~ctxt `Warning fmt + + + let error ~ctxt fmt = + generic_message ~ctxt `Error fmt + +end + +module OASISVersion = struct +(* # 22 "src/oasis/OASISVersion.ml" *) + + + open OASISGettext + + + + + + type s = string + + + type t = string + + + type comparator = + | VGreater of t + | VGreaterEqual of t + | VEqual of t + | VLesser of t + | VLesserEqual of t + | VOr of comparator * comparator + | VAnd of comparator * comparator + + + + (* Range of allowed characters *) + let is_digit c = + '0' <= c && c <= '9' + + + let is_alpha c = + ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') + + + let is_special = + function + | '.' | '+' | '-' | '~' -> true + | _ -> false + + + let rec version_compare v1 v2 = + if v1 <> "" || v2 <> "" then + begin + (* Compare ascii string, using special meaning for version + * related char + *) + let val_ascii c = + if c = '~' then -1 + else if is_digit c then 0 + else if c = '\000' then 0 + else if is_alpha c then Char.code c + else (Char.code c) + 256 + in + + let len1 = String.length v1 in + let len2 = String.length v2 in + + let p = ref 0 in + + (** Compare ascii part *) + let compare_vascii () = + let cmp = ref 0 in + while !cmp = 0 && + !p < len1 && !p < len2 && + not (is_digit v1.[!p] && is_digit v2.[!p]) do + cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); + incr p + done; + if !cmp = 0 && !p < len1 && !p = len2 then + val_ascii v1.[!p] + else if !cmp = 0 && !p = len1 && !p < len2 then + - (val_ascii v2.[!p]) + else + !cmp + in + + (** Compare digit part *) + let compare_digit () = + let extract_int v p = + let start_p = !p in + while !p < String.length v && is_digit v.[!p] do + incr p + done; + let substr = + String.sub v !p ((String.length v) - !p) + in + let res = + match String.sub v start_p (!p - start_p) with + | "" -> 0 + | s -> int_of_string s + in + res, substr + in + let i1, tl1 = extract_int v1 (ref !p) in + let i2, tl2 = extract_int v2 (ref !p) in + i1 - i2, tl1, tl2 + in + + match compare_vascii () with + | 0 -> + begin + match compare_digit () with + | 0, tl1, tl2 -> + if tl1 <> "" && is_digit tl1.[0] then + 1 + else if tl2 <> "" && is_digit tl2.[0] then + -1 + else + version_compare tl1 tl2 + | n, _, _ -> + n + end + | n -> + n + end + else + begin + 0 + end + + + let version_of_string str = str + + + let string_of_version t = t + + + let version_compare_string s1 s2 = + version_compare (version_of_string s1) (version_of_string s2) + + + let chop t = + try + let pos = + String.rindex t '.' + in + String.sub t 0 pos + with Not_found -> + t + + + let rec comparator_apply v op = + match op with + | VGreater cv -> + (version_compare v cv) > 0 + | VGreaterEqual cv -> + (version_compare v cv) >= 0 + | VLesser cv -> + (version_compare v cv) < 0 + | VLesserEqual cv -> + (version_compare v cv) <= 0 + | VEqual cv -> + (version_compare v cv) = 0 + | VOr (op1, op2) -> + (comparator_apply v op1) || (comparator_apply v op2) + | VAnd (op1, op2) -> + (comparator_apply v op1) && (comparator_apply v op2) + + + let rec string_of_comparator = + function + | VGreater v -> "> "^(string_of_version v) + | VEqual v -> "= "^(string_of_version v) + | VLesser v -> "< "^(string_of_version v) + | VGreaterEqual v -> ">= "^(string_of_version v) + | VLesserEqual v -> "<= "^(string_of_version v) + | VOr (c1, c2) -> + (string_of_comparator c1)^" || "^(string_of_comparator c2) + | VAnd (c1, c2) -> + (string_of_comparator c1)^" && "^(string_of_comparator c2) + + + let rec varname_of_comparator = + let concat p v = + OASISUtils.varname_concat + p + (OASISUtils.varname_of_string + (string_of_version v)) + in + function + | VGreater v -> concat "gt" v + | VLesser v -> concat "lt" v + | VEqual v -> concat "eq" v + | VGreaterEqual v -> concat "ge" v + | VLesserEqual v -> concat "le" v + | VOr (c1, c2) -> + (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) + | VAnd (c1, c2) -> + (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) + + + let rec comparator_ge v' = + let cmp v = version_compare v v' >= 0 in + function + | VEqual v + | VGreaterEqual v + | VGreater v -> cmp v + | VLesserEqual _ + | VLesser _ -> false + | VOr (c1, c2) -> comparator_ge v' c1 || comparator_ge v' c2 + | VAnd (c1, c2) -> comparator_ge v' c1 && comparator_ge v' c2 + + +end + +module OASISLicense = struct +(* # 22 "src/oasis/OASISLicense.ml" *) + + + (** License for _oasis fields + @author Sylvain Le Gall + *) + + + + + + type license = string + + + type license_exception = string + + + type license_version = + | Version of OASISVersion.t + | VersionOrLater of OASISVersion.t + | NoVersion + + + + type license_dep_5_unit = + { + license: license; + excption: license_exception option; + version: license_version; + } + + + + type license_dep_5 = + | DEP5Unit of license_dep_5_unit + | DEP5Or of license_dep_5 list + | DEP5And of license_dep_5 list + + + type t = + | DEP5License of license_dep_5 + | OtherLicense of string (* URL *) + + + +end + +module OASISExpr = struct +(* # 22 "src/oasis/OASISExpr.ml" *) + + + + + + open OASISGettext + + + type test = string + + + type flag = string + + + type t = + | EBool of bool + | ENot of t + | EAnd of t * t + | EOr of t * t + | EFlag of flag + | ETest of test * string + + + + type 'a choices = (t * 'a) list + + + let eval var_get t = + let rec eval' = + function + | EBool b -> + b + + | ENot e -> + not (eval' e) + + | EAnd (e1, e2) -> + (eval' e1) && (eval' e2) + + | EOr (e1, e2) -> + (eval' e1) || (eval' e2) + + | EFlag nm -> + let v = + var_get nm + in + assert(v = "true" || v = "false"); + (v = "true") + + | ETest (nm, vl) -> + let v = + var_get nm + in + (v = vl) + in + eval' t + + + let choose ?printer ?name var_get lst = + let rec choose_aux = + function + | (cond, vl) :: tl -> + if eval var_get cond then + vl + else + choose_aux tl + | [] -> + let str_lst = + if lst = [] then + s_ "" + else + String.concat + (s_ ", ") + (List.map + (fun (cond, vl) -> + match printer with + | Some p -> p vl + | None -> s_ "") + lst) + in + match name with + | Some nm -> + failwith + (Printf.sprintf + (f_ "No result for the choice list '%s': %s") + nm str_lst) + | None -> + failwith + (Printf.sprintf + (f_ "No result for a choice list: %s") + str_lst) + in + choose_aux (List.rev lst) + + +end + +module OASISText = struct +(* # 22 "src/oasis/OASISText.ml" *) + + + + type elt = + | Para of string + | Verbatim of string + | BlankLine + + + type t = elt list + +end + +module OASISTypes = struct +(* # 22 "src/oasis/OASISTypes.ml" *) + + + + + + type name = string + type package_name = string + type url = string + type unix_dirname = string + type unix_filename = string + type host_dirname = string + type host_filename = string + type prog = string + type arg = string + type args = string list + type command_line = (prog * arg list) + + + type findlib_name = string + type findlib_full = string + + + type compiled_object = + | Byte + | Native + | Best + + + + type dependency = + | FindlibPackage of findlib_full * OASISVersion.comparator option + | InternalLibrary of name + + + + type tool = + | ExternalTool of name + | InternalExecutable of name + + + + type vcs = + | Darcs + | Git + | Svn + | Cvs + | Hg + | Bzr + | Arch + | Monotone + | OtherVCS of url + + + + type plugin_kind = + [ `Configure + | `Build + | `Doc + | `Test + | `Install + | `Extra + ] + + + type plugin_data_purpose = + [ `Configure + | `Build + | `Install + | `Clean + | `Distclean + | `Install + | `Uninstall + | `Test + | `Doc + | `Extra + | `Other of string + ] + + + type 'a plugin = 'a * name * OASISVersion.t option + + + type all_plugin = plugin_kind plugin + + + type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list + + +(* # 115 "src/oasis/OASISTypes.ml" *) + + + type 'a conditional = 'a OASISExpr.choices + + + type custom = + { + pre_command: (command_line option) conditional; + post_command: (command_line option) conditional; + } + + + + type common_section = + { + cs_name: name; + cs_data: PropList.Data.t; + cs_plugin_data: plugin_data; + } + + + + type build_section = + { + bs_build: bool conditional; + bs_install: bool conditional; + bs_path: unix_dirname; + bs_compiled_object: compiled_object; + bs_build_depends: dependency list; + bs_build_tools: tool list; + bs_c_sources: unix_filename list; + bs_data_files: (unix_filename * unix_filename option) list; + bs_ccopt: args conditional; + bs_cclib: args conditional; + bs_dlllib: args conditional; + bs_dllpath: args conditional; + bs_byteopt: args conditional; + bs_nativeopt: args conditional; + } + + + + type library = + { + lib_modules: string list; + lib_pack: bool; + lib_internal_modules: string list; + lib_findlib_parent: findlib_name option; + lib_findlib_name: findlib_name option; + 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; + } + + + type flag = + { + flag_description: string option; + flag_default: bool conditional; + } + + + type source_repository = + { + src_repo_type: vcs; + src_repo_location: url; + src_repo_browser: url option; + src_repo_module: string option; + src_repo_branch: string option; + src_repo_tag: string option; + src_repo_subdir: unix_filename option; + } + + + type test = + { + test_type: [`Test] plugin; + test_command: command_line conditional; + test_custom: custom; + test_working_directory: unix_filename option; + test_run: bool conditional; + test_tools: tool list; + } + + + type doc_format = + | HTML of unix_filename + | DocText + | PDF + | PostScript + | Info of unix_filename + | DVI + | OtherDoc + + + + type doc = + { + doc_type: [`Doc] plugin; + doc_custom: custom; + doc_build: bool conditional; + doc_install: bool conditional; + doc_install_dir: unix_filename; + doc_title: string; + doc_authors: string list; + doc_abstract: string option; + doc_format: doc_format; + doc_data_files: (unix_filename * unix_filename option) list; + doc_build_tools: tool list; + } + + + 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 + | Test of common_section * test + | Doc of common_section * doc + + + + type section_kind = + [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] + + + type package = + { + oasis_version: OASISVersion.t; + ocaml_version: OASISVersion.comparator option; + findlib_version: OASISVersion.comparator option; + alpha_features: string list; + beta_features: string list; + name: package_name; + version: OASISVersion.t; + license: OASISLicense.t; + license_file: unix_filename option; + copyrights: string list; + maintainers: string list; + authors: string list; + homepage: url option; + synopsis: string; + description: OASISText.t option; + categories: url list; + + conf_type: [`Configure] plugin; + conf_custom: custom; + + build_type: [`Build] plugin; + build_custom: custom; + + install_type: [`Install] plugin; + install_custom: custom; + uninstall_custom: custom; + + clean_custom: custom; + distclean_custom: custom; + + files_ab: unix_filename list; + sections: section list; + plugins: [`Extra] plugin list; + disable_oasis_section: unix_filename list; + schema_data: PropList.Data.t; + plugin_data: plugin_data; + } + + +end + +module OASISFeatures = struct +(* # 22 "src/oasis/OASISFeatures.ml" *) + + open OASISTypes + open OASISUtils + open OASISGettext + open OASISVersion + + module MapPlugin = + Map.Make + (struct + type t = plugin_kind * name + let compare = Pervasives.compare + end) + + module Data = + struct + type t = + { + oasis_version: OASISVersion.t; + plugin_versions: OASISVersion.t option MapPlugin.t; + alpha_features: string list; + beta_features: string list; + } + + let create oasis_version alpha_features beta_features = + { + oasis_version = oasis_version; + plugin_versions = MapPlugin.empty; + alpha_features = alpha_features; + beta_features = beta_features + } + + let of_package pkg = + create + pkg.OASISTypes.oasis_version + pkg.OASISTypes.alpha_features + pkg.OASISTypes.beta_features + + let add_plugin (plugin_kind, plugin_name, plugin_version) t = + {t with + plugin_versions = MapPlugin.add + (plugin_kind, plugin_name) + plugin_version + t.plugin_versions} + + let plugin_version plugin_kind plugin_name t = + MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions + + let to_string t = + Printf.sprintf + "oasis_version: %s; alpha_features: %s; beta_features: %s; \ + plugins_version: %s" + (OASISVersion.string_of_version t.oasis_version) + (String.concat ", " t.alpha_features) + (String.concat ", " t.beta_features) + (String.concat ", " + (MapPlugin.fold + (fun (_, plg) ver_opt acc -> + (plg^ + (match ver_opt with + | Some v -> + " "^(OASISVersion.string_of_version v) + | None -> "")) + :: acc) + t.plugin_versions [])) + end + + type origin = + | Field of string * string + | Section of string + | NoOrigin + + type stage = Alpha | Beta + + + let string_of_stage = + function + | Alpha -> "alpha" + | Beta -> "beta" + + + let field_of_stage = + function + | Alpha -> "AlphaFeatures" + | Beta -> "BetaFeatures" + + type publication = InDev of stage | SinceVersion of OASISVersion.t + + type t = + { + name: string; + plugin: all_plugin option; + publication: publication; + description: unit -> string; + } + + (* TODO: mutex protect this. *) + let all_features = Hashtbl.create 13 + + + let since_version ver_str = SinceVersion (version_of_string ver_str) + let alpha = InDev Alpha + let beta = InDev Beta + + + let to_string t = + Printf.sprintf + "feature: %s; plugin: %s; publication: %s" + t.name + (match t.plugin with + | None -> "" + | Some (_, nm, _) -> nm) + (match t.publication with + | InDev stage -> string_of_stage stage + | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) + + let data_check t data origin = + let no_message = "no message" in + + let check_feature features stage = + let has_feature = List.mem t.name features in + if not has_feature then + match origin with + | Field (fld, where) -> + Some + (Printf.sprintf + (f_ "Field %s in %s is only available when feature %s \ + is in field %s.") + fld where t.name (field_of_stage stage)) + | Section sct -> + Some + (Printf.sprintf + (f_ "Section %s is only available when features %s \ + is in field %s.") + sct t.name (field_of_stage stage)) + | NoOrigin -> + Some no_message + else + None + in + + let version_is_good ~min_version version fmt = + let version_is_good = + OASISVersion.comparator_apply + version (OASISVersion.VGreaterEqual min_version) + in + Printf.ksprintf + (fun str -> + if version_is_good then + None + else + Some str) + fmt + in + + match origin, t.plugin, t.publication with + | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha + | _, _, InDev Beta -> check_feature data.Data.beta_features Beta + | Field(fld, where), None, SinceVersion min_version -> + version_is_good ~min_version data.Data.oasis_version + (f_ "Field %s in %s is only valid since OASIS v%s, update \ + OASISFormat field from '%s' to '%s' after checking \ + OASIS changelog.") + fld where (string_of_version min_version) + (string_of_version data.Data.oasis_version) + (string_of_version min_version) + + | Field(fld, where), Some(plugin_knd, plugin_name, _), + SinceVersion min_version -> + begin + try + let plugin_version_current = + try + match Data.plugin_version plugin_knd plugin_name data with + | Some ver -> ver + | None -> + failwithf + (f_ "Field %s in %s is only valid for the OASIS \ + plugin %s since v%s, but no plugin version is \ + defined in the _oasis file, change '%s' to \ + '%s (%s)' in your _oasis file.") + fld where plugin_name (string_of_version min_version) + plugin_name + plugin_name (string_of_version min_version) + with Not_found -> + failwithf + (f_ "Field %s in %s is only valid when the OASIS plugin %s \ + is defined.") + fld where plugin_name + in + version_is_good ~min_version plugin_version_current + (f_ "Field %s in %s is only valid for the OASIS plugin %s \ + since v%s, update your plugin from '%s (%s)' to \ + '%s (%s)' after checking the plugin's changelog.") + fld where plugin_name (string_of_version min_version) + plugin_name (string_of_version plugin_version_current) + plugin_name (string_of_version min_version) + with Failure msg -> + Some msg + end + + | Section sct, None, SinceVersion min_version -> + version_is_good ~min_version data.Data.oasis_version + (f_ "Section %s is only valid for since OASIS v%s, update \ + OASISFormat field from '%s' to '%s' after checking OASIS \ + changelog.") + sct (string_of_version min_version) + (string_of_version data.Data.oasis_version) + (string_of_version min_version) + + | Section sct, Some(plugin_knd, plugin_name, _), + SinceVersion min_version -> + begin + try + let plugin_version_current = + try + match Data.plugin_version plugin_knd plugin_name data with + | Some ver -> ver + | None -> + failwithf + (f_ "Section %s is only valid for the OASIS \ + plugin %s since v%s, but no plugin version is \ + defined in the _oasis file, change '%s' to \ + '%s (%s)' in your _oasis file.") + sct plugin_name (string_of_version min_version) + plugin_name + plugin_name (string_of_version min_version) + with Not_found -> + failwithf + (f_ "Section %s is only valid when the OASIS plugin %s \ + is defined.") + sct plugin_name + in + version_is_good ~min_version plugin_version_current + (f_ "Section %s is only valid for the OASIS plugin %s \ + since v%s, update your plugin from '%s (%s)' to \ + '%s (%s)' after checking the plugin's changelog.") + sct plugin_name (string_of_version min_version) + plugin_name (string_of_version plugin_version_current) + plugin_name (string_of_version min_version) + with Failure msg -> + Some msg + end + + | NoOrigin, None, SinceVersion min_version -> + version_is_good ~min_version data.Data.oasis_version "%s" no_message + + | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> + begin + try + let plugin_version_current = + match Data.plugin_version plugin_knd plugin_name data with + | Some ver -> ver + | None -> raise Not_found + in + version_is_good ~min_version plugin_version_current + "%s" no_message + with Not_found -> + Some no_message + end + + + let data_assert t data origin = + match data_check t data origin with + | None -> () + | Some str -> failwith str + + + let data_test t data = + match data_check t data NoOrigin with + | None -> true + | Some str -> false + + + let package_test t pkg = + data_test t (Data.of_package pkg) + + + let create ?plugin name publication description = + let () = + if Hashtbl.mem all_features name then + failwithf "Feature '%s' is already declared." name + in + let t = + { + name = name; + plugin = plugin; + publication = publication; + description = description; + } + in + Hashtbl.add all_features name t; + t + + + let get_stage name = + try + (Hashtbl.find all_features name).publication + with Not_found -> + failwithf (f_ "Feature %s doesn't exist.") name + + + let list () = + Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] + + (* + * Real flags. + *) + + + let features = + create "features_fields" + (since_version "0.4") + (fun () -> + s_ "Enable to experiment not yet official features.") + + + let flag_docs = + create "flag_docs" + (since_version "0.3") + (fun () -> + s_ "Building docs require '-docs' flag at configure.") + + + let flag_tests = + create "flag_tests" + (since_version "0.3") + (fun () -> + s_ "Running tests require '-tests' flag at configure.") + + + let pack = + create "pack" + (since_version "0.3") + (fun () -> + s_ "Allow to create packed library.") + + + let section_object = + create "section_object" beta + (fun () -> + s_ "Implement an object section.") + + + let dynrun_for_release = + create "dynrun_for_release" alpha + (fun () -> + s_ "Make '-setup-update dynamic' suitable for releasing project.") + + + let compiled_setup_ml = + create "compiled_setup_ml" alpha + (fun () -> + s_ "It compiles the setup.ml and speed-up actions done with it.") + + let disable_oasis_section = + create "disable_oasis_section" alpha + (fun () -> + s_ "Allows the OASIS section comments and digest to be omitted in \ + generated files.") +end + +module OASISUnixPath = struct +(* # 22 "src/oasis/OASISUnixPath.ml" *) + + + type unix_filename = string + type unix_dirname = string + + + type host_filename = string + type host_dirname = string + + + let current_dir_name = "." + + + let parent_dir_name = ".." + + + let is_current_dir fn = + fn = current_dir_name || fn = "" + + + let concat f1 f2 = + if is_current_dir f1 then + f2 + else + let f1' = + try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 + in + f1'^"/"^f2 + + + let make = + function + | hd :: tl -> + List.fold_left + (fun f p -> concat f p) + hd + tl + | [] -> + invalid_arg "OASISUnixPath.make" + + + let dirname f = + try + String.sub f 0 (String.rindex f '/') + with Not_found -> + current_dir_name + + + let basename f = + try + let pos_start = + (String.rindex f '/') + 1 + in + String.sub f pos_start ((String.length f) - pos_start) + with Not_found -> + f + + + let chop_extension f = + try + let last_dot = + String.rindex f '.' + in + let sub = + String.sub f 0 last_dot + in + try + let last_slash = + String.rindex f '/' + in + if last_slash < last_dot then + sub + else + f + with Not_found -> + sub + + with Not_found -> + f + + + let capitalize_file f = + let dir = dirname f in + let base = basename f in + concat dir (String.capitalize base) + + + let uncapitalize_file f = + let dir = dirname f in + let base = basename f in + concat dir (String.uncapitalize base) + + +end + +module OASISHostPath = struct +(* # 22 "src/oasis/OASISHostPath.ml" *) + + + open Filename + + + module Unix = OASISUnixPath + + + let make = + function + | [] -> + invalid_arg "OASISHostPath.make" + | hd :: tl -> + List.fold_left Filename.concat hd tl + + + let of_unix ufn = + if Sys.os_type = "Unix" then + ufn + else + make + (List.map + (fun p -> + if p = Unix.current_dir_name then + current_dir_name + else if p = Unix.parent_dir_name then + parent_dir_name + else + p) + (OASISString.nsplit ufn '/')) + + +end + +module OASISSection = struct +(* # 22 "src/oasis/OASISSection.ml" *) + + + open OASISTypes + + + let section_kind_common = + function + | Library (cs, _, _) -> + `Library, cs + | Object (cs, _, _) -> + `Object, cs + | Executable (cs, _, _) -> + `Executable, cs + | Flag (cs, _) -> + `Flag, cs + | SrcRepo (cs, _) -> + `SrcRepo, cs + | Test (cs, _) -> + `Test, cs + | Doc (cs, _) -> + `Doc, cs + + + let section_common sct = + snd (section_kind_common sct) + + + 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) + | Test (_, tst) -> Test (cs, tst) + | Doc (_, doc) -> Doc (cs, doc) + + + (** Key used to identify section + *) + let section_id sct = + let k, cs = + section_kind_common sct + in + k, cs.cs_name + + + let string_of_section sct = + let k, nm = + section_id sct + in + (match k with + | `Library -> "library" + | `Object -> "object" + | `Executable -> "executable" + | `Flag -> "flag" + | `SrcRepo -> "src repository" + | `Test -> "test" + | `Doc -> "doc") + ^" "^nm + + + let section_find id scts = + List.find + (fun sct -> id = section_id sct) + scts + + + module CSection = + struct + type t = section + + let id = section_id + + let compare t1 t2 = + compare (id t1) (id t2) + + let equal t1 t2 = + (id t1) = (id t2) + + let hash t = + Hashtbl.hash (id t) + end + + + module MapSection = Map.Make(CSection) + module SetSection = Set.Make(CSection) + + +end + +module OASISBuildSection = struct +(* # 22 "src/oasis/OASISBuildSection.ml" *) + + +end + +module OASISExecutable = struct +(* # 22 "src/oasis/OASISExecutable.ml" *) + + + open OASISTypes + + + let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = + let dir = + OASISUnixPath.concat + bs.bs_path + (OASISUnixPath.dirname exec.exec_main_is) + in + let is_native_exec = + match bs.bs_compiled_object with + | Native -> true + | Best -> is_native () + | Byte -> false + in + + OASISUnixPath.concat + dir + (cs.cs_name^(suffix_program ())), + + if not is_native_exec && + not exec.exec_custom && + bs.bs_c_sources <> [] then + Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) + else + None + + +end + +module OASISLibrary = struct +(* # 22 "src/oasis/OASISLibrary.ml" *) + + + open OASISTypes + open OASISUtils + open OASISGettext + open OASISSection + + + (* Look for a module file, considering capitalization or not. *) + let find_module source_file_exists bs modul = + let possible_base_fn = + List.map + (OASISUnixPath.concat bs.bs_path) + [modul; + OASISUnixPath.uncapitalize_file modul; + OASISUnixPath.capitalize_file modul] + in + (* TODO: we should be able to be able to determine the source for every + * files. Hence we should introduce a Module(source: fn) for the fields + * Modules and InternalModules + *) + List.fold_left + (fun acc base_fn -> + match acc with + | `No_sources _ -> + begin + let file_found = + List.fold_left + (fun acc ext -> + if source_file_exists (base_fn^ext) then + (base_fn^ext) :: acc + else + acc) + [] + [".ml"; ".mli"; ".mll"; ".mly"] + in + match file_found with + | [] -> + acc + | lst -> + `Sources (base_fn, lst) + end + | `Sources _ -> + acc) + (`No_sources possible_base_fn) + possible_base_fn + + + 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 + | `Sources (base_fn, lst) -> + (base_fn, lst) :: acc + | `No_sources _ -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in library %s") + modul cs.cs_name; + acc) + [] + (lib.lib_modules @ lib.lib_internal_modules) + + + let generated_unix_files + ~ctxt + ~is_native + ~has_native_dynlink + ~ext_lib + ~ext_dll + ~source_file_exists + (cs, bs, lib) = + + let find_modules lst ext = + let find_module modul = + match find_module source_file_exists bs modul with + | `Sources (base_fn, [fn]) when ext <> "cmi" + && Filename.check_suffix fn ".mli" -> + None (* No implementation files for pure interface. *) + | `Sources (base_fn, _) -> + Some [base_fn] + | `No_sources lst -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in library %s") + modul cs.cs_name; + Some lst + in + List.fold_left + (fun acc nm -> + match find_module nm with + | None -> acc + | Some base_fns -> + List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) + [] + lst + in + + (* The headers that should be compiled along *) + let headers = + if lib.lib_pack then + [] + else + find_modules + lib.lib_modules + "cmi" + in + + (* The .cmx that be compiled along *) + let cmxs = + let should_be_built = + match bs.bs_compiled_object with + | Native -> true + | Best -> is_native + | Byte -> false + in + if should_be_built then + if lib.lib_pack then + find_modules + [cs.cs_name] + "cmx" + else + find_modules + (lib.lib_modules @ lib.lib_internal_modules) + "cmx" + else + [] + in + + let acc_nopath = + [] + in + + (* Compute what libraries should be built *) + let acc_nopath = + (* Add the packed header file if required *) + let add_pack_header acc = + if lib.lib_pack then + [cs.cs_name^".cmi"] :: acc + else + acc + in + let byte acc = + add_pack_header ([cs.cs_name^".cma"] :: acc) + in + let native acc = + let acc = + add_pack_header + (if has_native_dynlink then + [cs.cs_name^".cmxs"] :: acc + else acc) + in + [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc + in + match bs.bs_compiled_object with + | Native -> + byte (native acc_nopath) + | Best when is_native -> + byte (native acc_nopath) + | Byte | Best -> + byte acc_nopath + in + + (* Add C library to be built *) + let acc_nopath = + if bs.bs_c_sources <> [] then + begin + ["lib"^cs.cs_name^"_stubs"^ext_lib] + :: + ["dll"^cs.cs_name^"_stubs"^ext_dll] + :: + acc_nopath + end + else + acc_nopath + in + + (* All the files generated *) + List.rev_append + (List.rev_map + (List.rev_map + (OASISUnixPath.concat bs.bs_path)) + acc_nopath) + (headers @ cmxs) + + +end + +module OASISObject = struct +(* # 22 "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 +(* # 22 "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 + + + let findlib_mapping pkg = + (* Map from library name to either full findlib name or parts + parent. *) + let fndlb_parts_of_lib_name = + let fndlb_parts cs lib = + let name = + match lib.lib_findlib_name with + | Some nm -> nm + | None -> cs.cs_name + in + let name = + String.concat "." (lib.lib_findlib_containers @ [name]) + in + name + in + List.fold_left + (fun mp -> + function + | Library (cs, _, lib) -> + begin + let lib_name = cs.cs_name in + let fndlb_parts = fndlb_parts cs lib in + if MapString.mem lib_name mp then + failwithf + (f_ "The library name '%s' is used more than once.") + lib_name; + match lib.lib_findlib_parent with + | Some lib_name_parent -> + MapString.add + lib_name + (`Unsolved (lib_name_parent, fndlb_parts)) + mp + | None -> + MapString.add + lib_name + (`Solved fndlb_parts) + 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 + pkg.sections + in + + (* Solve the above graph to be only library name to full findlib name. *) + let fndlb_name_of_lib_name = + let rec solve visited mp lib_name lib_name_child = + if SetString.mem lib_name visited then + failwithf + (f_ "Library '%s' is involved in a cycle \ + with regard to findlib naming.") + lib_name; + let visited = SetString.add lib_name visited in + try + match MapString.find lib_name mp with + | `Solved fndlb_nm -> + fndlb_nm, mp + | `Unsolved (lib_nm_parent, post_fndlb_nm) -> + let pre_fndlb_nm, mp = + solve visited mp lib_nm_parent lib_name + in + let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in + fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp + with Not_found -> + failwithf + (f_ "Library '%s', which is defined as the findlib parent of \ + library '%s', doesn't exist.") + lib_name lib_name_child + in + let mp = + MapString.fold + (fun lib_name status mp -> + match status with + | `Solved _ -> + (* Solved initialy, no need to go further *) + mp + | `Unsolved _ -> + let _, mp = solve SetString.empty mp lib_name "" in + mp) + fndlb_parts_of_lib_name + fndlb_parts_of_lib_name + in + MapString.map + (function + | `Solved fndlb_nm -> fndlb_nm + | `Unsolved _ -> assert false) + mp + in + + (* Convert an internal library name to a findlib name. *) + let findlib_name_of_library_name lib_nm = + try + MapString.find lib_nm fndlb_name_of_lib_name + with Not_found -> + raise (InternalLibraryNotFound lib_nm) + in + + (* Add a library to the tree. + *) + let add sct mp = + let fndlb_fullname = + let cs, _, _ = sct in + let lib_name = cs.cs_name in + findlib_name_of_library_name lib_name + in + let rec add_children nm_lst (children: tree MapString.t) = + match nm_lst with + | (hd :: tl) -> + begin + let node = + try + add_node tl (MapString.find hd children) + with Not_found -> + (* New node *) + new_node tl + in + MapString.add hd node children + end + | [] -> + (* Should not have a nameless library. *) + assert false + and add_node tl node = + if tl = [] then + begin + match node with + | Node (None, children) -> + Node (Some sct, children) + | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> + (* TODO: allow to merge Package, i.e. + * archive(byte) = "foo.cma foo_init.cmo" + *) + let cs, _, _ = sct in + failwithf + (f_ "Library '%s' and '%s' have the same findlib name '%s'") + cs.cs_name cs'.cs_name fndlb_fullname + end + else + begin + match node with + | Leaf data -> + Node (Some data, add_children tl MapString.empty) + | Node (data_opt, children) -> + Node (data_opt, add_children tl children) + end + and new_node = + function + | [] -> + Leaf sct + | hd :: tl -> + Node (None, MapString.add hd (new_node tl) MapString.empty) + in + add_children (OASISString.nsplit fndlb_fullname '.') mp + in + + let rec group_of_tree mp = + MapString.fold + (fun nm node acc -> + let cur = + match node with + | Node (Some (cs, bs, lib), children) -> + Package (nm, cs, bs, lib, group_of_tree children) + | Node (None, children) -> + Container (nm, group_of_tree children) + | Leaf (cs, bs, lib) -> + Package (nm, cs, bs, lib, []) + in + cur :: acc) + mp [] + in + + let group_mp = + List.fold_left + (fun mp -> + function + | Library (cs, bs, lib) -> + add (cs, bs, `Library lib) mp + | Object (cs, bs, obj) -> + add (cs, bs, `Object obj) mp + | _ -> + mp) + MapString.empty + pkg.sections + in + + let groups = + group_of_tree group_mp + in + + let library_name_of_findlib_name = + Lazy.lazy_from_fun + (fun () -> + (* Revert findlib_name_of_library_name. *) + MapString.fold + (fun k v mp -> MapString.add v k mp) + fndlb_name_of_lib_name + MapString.empty) + in + let library_name_of_findlib_name fndlb_nm = + try + MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) + with Not_found -> + raise (FindlibPackageNotFound fndlb_nm) + in + + groups, + findlib_name_of_library_name, + library_name_of_findlib_name + + + let findlib_of_group = + function + | Container (fndlb_nm, _) + | Package (fndlb_nm, _, _, _, _) -> fndlb_nm + + + let root_of_group grp = + let rec root_lib_aux = + (* We do a DFS in the group. *) + function + | Container (_, children) -> + List.fold_left + (fun res grp -> + if res = None then + root_lib_aux grp + else + res) + None + children + | Package (_, cs, bs, lib, _) -> + Some (cs, bs, lib) + in + match root_lib_aux grp with + | Some res -> + res + | None -> + failwithf + (f_ "Unable to determine root library of findlib library '%s'") + (findlib_of_group grp) + + +end + +module OASISFlag = struct +(* # 22 "src/oasis/OASISFlag.ml" *) + + +end + +module OASISPackage = struct +(* # 22 "src/oasis/OASISPackage.ml" *) + + +end + +module OASISSourceRepository = struct +(* # 22 "src/oasis/OASISSourceRepository.ml" *) + + +end + +module OASISTest = struct +(* # 22 "src/oasis/OASISTest.ml" *) + + +end + +module OASISDocument = struct +(* # 22 "src/oasis/OASISDocument.ml" *) + + +end + +module OASISExec = struct +(* # 22 "src/oasis/OASISExec.ml" *) + + + open OASISGettext + open OASISUtils + open OASISMessage + + + (* TODO: I don't like this quote, it is there because $(rm) foo expands to + * 'rm -f' foo... + *) + let run ~ctxt ?f_exit_code ?(quote=true) cmd args = + let cmd = + if quote then + if Sys.os_type = "Win32" then + if String.contains cmd ' ' then + (* Double the 1st double quote... win32... sigh *) + "\""^(Filename.quote cmd) + else + cmd + else + Filename.quote cmd + else + cmd + in + let cmdline = + String.concat " " (cmd :: args) + in + info ~ctxt (f_ "Running command '%s'") cmdline; + match f_exit_code, Sys.command cmdline with + | None, 0 -> () + | None, i -> + failwithf + (f_ "Command '%s' terminated with error code %d") + cmdline i + | Some f, i -> + f i + + + let run_read_output ~ctxt ?f_exit_code cmd args = + let fn = + Filename.temp_file "oasis-" ".txt" + in + try + begin + let () = + run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) + in + let chn = + open_in fn + in + let routput = + ref [] + in + begin + try + while true do + routput := (input_line chn) :: !routput + done + with End_of_file -> + () + end; + close_in chn; + Sys.remove fn; + List.rev !routput + end + with e -> + (try Sys.remove fn with _ -> ()); + raise e + + + let run_read_one_line ~ctxt ?f_exit_code cmd args = + match run_read_output ~ctxt ?f_exit_code cmd args with + | [fst] -> + fst + | lst -> + failwithf + (f_ "Command return unexpected output %S") + (String.concat "\n" lst) +end + +module OASISFileUtil = struct +(* # 22 "src/oasis/OASISFileUtil.ml" *) + + + open OASISGettext + + + let file_exists_case fn = + let dirname = Filename.dirname fn in + let basename = Filename.basename fn in + if Sys.file_exists dirname then + if basename = Filename.current_dir_name then + true + else + List.mem + basename + (Array.to_list (Sys.readdir dirname)) + else + false + + + let find_file ?(case_sensitive=true) paths exts = + + (* Cardinal product of two list *) + let ( * ) lst1 lst2 = + List.flatten + (List.map + (fun a -> + List.map + (fun b -> a, b) + lst2) + lst1) + in + + let rec combined_paths lst = + match lst with + | p1 :: p2 :: tl -> + let acc = + (List.map + (fun (a, b) -> Filename.concat a b) + (p1 * p2)) + in + combined_paths (acc :: tl) + | [e] -> + e + | [] -> + [] + in + + let alternatives = + List.map + (fun (p, e) -> + if String.length e > 0 && e.[0] <> '.' then + p ^ "." ^ e + else + p ^ e) + ((combined_paths paths) * exts) + in + List.find (fun file -> + (if case_sensitive then + file_exists_case file + else + Sys.file_exists file) + && not (Sys.is_directory file) + ) alternatives + + + let which ~ctxt prg = + let path_sep = + match Sys.os_type with + | "Win32" -> + ';' + | _ -> + ':' + in + let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in + let exec_ext = + match Sys.os_type with + | "Win32" -> + "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) + | _ -> + [""] + in + find_file ~case_sensitive:false [path_lst; [prg]] exec_ext + + + (**/**) + let rec fix_dir dn = + (* Windows hack because Sys.file_exists "src\\" = false when + * Sys.file_exists "src" = true + *) + let ln = + String.length dn + in + if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then + fix_dir (String.sub dn 0 (ln - 1)) + else + dn + + + let q = Filename.quote + (**/**) + + + let cp ~ctxt ?(recurse=false) src tgt = + if recurse then + match Sys.os_type with + | "Win32" -> + OASISExec.run ~ctxt + "xcopy" [q src; q tgt; "/E"] + | _ -> + OASISExec.run ~ctxt + "cp" ["-r"; q src; q tgt] + else + OASISExec.run ~ctxt + (match Sys.os_type with + | "Win32" -> "copy" + | _ -> "cp") + [q src; q tgt] + + + let mkdir ~ctxt tgt = + OASISExec.run ~ctxt + (match Sys.os_type with + | "Win32" -> "md" + | _ -> "mkdir") + [q tgt] + + + let rec mkdir_parent ~ctxt f tgt = + let tgt = + fix_dir tgt + in + if Sys.file_exists tgt then + begin + if not (Sys.is_directory tgt) then + OASISUtils.failwithf + (f_ "Cannot create directory '%s', a file of the same name already \ + exists") + tgt + end + else + begin + mkdir_parent ~ctxt f (Filename.dirname tgt); + if not (Sys.file_exists tgt) then + begin + f tgt; + mkdir ~ctxt tgt + end + end + + + let rmdir ~ctxt tgt = + if Sys.readdir tgt = [||] then begin + match Sys.os_type with + | "Win32" -> + OASISExec.run ~ctxt "rd" [q tgt] + | _ -> + OASISExec.run ~ctxt "rm" ["-r"; q tgt] + end else begin + OASISMessage.error ~ctxt + (f_ "Cannot remove directory '%s': not empty.") + tgt + end + + + let glob ~ctxt fn = + let basename = + Filename.basename fn + in + if String.length basename >= 2 && + basename.[0] = '*' && + basename.[1] = '.' then + begin + let ext_len = + (String.length basename) - 2 + in + let ext = + String.sub basename 2 ext_len + in + let dirname = + Filename.dirname fn + in + Array.fold_left + (fun acc fn -> + try + let fn_ext = + String.sub + fn + ((String.length fn) - ext_len) + ext_len + in + if fn_ext = ext then + (Filename.concat dirname fn) :: acc + else + acc + with Invalid_argument _ -> + acc) + [] + (Sys.readdir dirname) + end + else + begin + if file_exists_case fn then + [fn] + else + [] + end +end + + +# 2878 "setup.ml" +module BaseEnvLight = struct +(* # 22 "src/base/BaseEnvLight.ml" *) + + + module MapString = Map.Make(String) + + + type t = string MapString.t + + + let default_filename = + Filename.concat + (Sys.getcwd ()) + "setup.data" + + + let load ?(allow_empty=false) ?(filename=default_filename) () = + if Sys.file_exists filename then + begin + let chn = + open_in_bin filename + in + let st = + Stream.of_channel chn + in + let line = + ref 1 + in + let st_line = + Stream.from + (fun _ -> + try + match Stream.next st with + | '\n' -> incr line; Some '\n' + | c -> Some c + with Stream.Failure -> None) + in + let lexer = + Genlex.make_lexer ["="] st_line + in + let rec read_file mp = + match Stream.npeek 3 lexer with + | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> + Stream.junk lexer; + Stream.junk lexer; + Stream.junk lexer; + read_file (MapString.add nm value mp) + | [] -> + mp + | _ -> + failwith + (Printf.sprintf + "Malformed data file '%s' line %d" + filename !line) + in + let mp = + read_file MapString.empty + in + close_in chn; + mp + end + else if allow_empty then + begin + MapString.empty + end + else + begin + failwith + (Printf.sprintf + "Unable to load environment, the file '%s' doesn't exist." + filename) + end + + + let rec var_expand str env = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) env + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + + + let var_get name env = + var_expand (MapString.find name env) env + + + let var_choose lst env = + OASISExpr.choose + (fun nm -> var_get nm env) + lst +end + + +# 2983 "setup.ml" +module BaseContext = struct +(* # 22 "src/base/BaseContext.ml" *) + + (* TODO: get rid of this module. *) + open OASISContext + + + let args () = fst (fspecs ()) + + + let default = default + +end + +module BaseMessage = struct +(* # 22 "src/base/BaseMessage.ml" *) + + + (** Message to user, overrid for Base + @author Sylvain Le Gall + *) + open OASISMessage + open BaseContext + + + let debug fmt = debug ~ctxt:!default fmt + + + let info fmt = info ~ctxt:!default fmt + + + let warning fmt = warning ~ctxt:!default fmt + + + let error fmt = error ~ctxt:!default fmt + +end + +module BaseEnv = struct +(* # 22 "src/base/BaseEnv.ml" *) + + open OASISGettext + open OASISUtils + open PropList + + + module MapString = BaseEnvLight.MapString + + + type origin_t = + | ODefault + | OGetEnv + | OFileLoad + | OCommandLine + + + type cli_handle_t = + | CLINone + | CLIAuto + | CLIWith + | CLIEnable + | CLIUser of (Arg.key * Arg.spec * Arg.doc) list + + + type definition_t = + { + hide: bool; + dump: bool; + cli: cli_handle_t; + arg_help: string option; + group: string option; + } + + + let schema = + Schema.create "environment" + + + (* Environment data *) + let env = + Data.create () + + + (* Environment data from file *) + let env_from_file = + ref MapString.empty + + + (* Lexer for var *) + let var_lxr = + Genlex.make_lexer [] + + + let rec var_expand str = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + (* TODO: this is a quick hack to allow calling Test.Command + * without defining executable name really. I.e. if there is + * an exec Executable toto, then $(toto) should be replace + * by its real name. It is however useful to have this function + * for other variable that depend on the host and should be + * written better than that. + *) + let st = + var_lxr (Stream.of_string var) + in + match Stream.npeek 3 st with + | [Genlex.Ident "utoh"; Genlex.Ident nm] -> + OASISHostPath.of_unix (var_get nm) + | [Genlex.Ident "utoh"; Genlex.String s] -> + OASISHostPath.of_unix s + | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> + String.escaped (var_get nm) + | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> + String.escaped s + | [Genlex.Ident nm] -> + var_get nm + | _ -> + failwithf + (f_ "Unknown expression '%s' in variable expansion of %s.") + var + str + with + | Unknown_field (_, _) -> + failwithf + (f_ "No variable %s defined when trying to expand %S.") + var + str + | Stream.Error e -> + failwithf + (f_ "Syntax error when parsing '%s' when trying to \ + expand %S: %s") + var + str + e) + str; + Buffer.contents buff + + + and var_get name = + let vl = + try + Schema.get schema env name + with Unknown_field _ as e -> + begin + try + MapString.find name !env_from_file + with Not_found -> + raise e + end + in + var_expand vl + + + let var_choose ?printer ?name lst = + OASISExpr.choose + ?printer + ?name + var_get + lst + + + let var_protect vl = + let buff = + Buffer.create (String.length vl) + in + String.iter + (function + | '$' -> Buffer.add_string buff "\\$" + | c -> Buffer.add_char buff c) + vl; + Buffer.contents buff + + + let var_define + ?(hide=false) + ?(dump=true) + ?short_desc + ?(cli=CLINone) + ?arg_help + ?group + name (* TODO: type constraint on the fact that name must be a valid OCaml + id *) + dflt = + + let default = + [ + OFileLoad, (fun () -> MapString.find name !env_from_file); + ODefault, dflt; + OGetEnv, (fun () -> Sys.getenv name); + ] + in + + let extra = + { + hide = hide; + dump = dump; + cli = cli; + arg_help = arg_help; + group = group; + } + in + + (* Try to find a value that can be defined + *) + let var_get_low lst = + let errors, res = + List.fold_left + (fun (errors, res) (o, v) -> + if res = None then + begin + try + errors, Some (v ()) + with + | Not_found -> + errors, res + | Failure rsn -> + (rsn :: errors), res + | e -> + (Printexc.to_string e) :: errors, res + end + else + errors, res) + ([], None) + (List.sort + (fun (o1, _) (o2, _) -> + Pervasives.compare o2 o1) + lst) + in + match res, errors with + | Some v, _ -> + v + | None, [] -> + raise (Not_set (name, None)) + | None, lst -> + raise (Not_set (name, Some (String.concat (s_ ", ") lst))) + in + + let help = + match short_desc with + | Some fs -> Some fs + | None -> None + in + + let var_get_lst = + FieldRO.create + ~schema + ~name + ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) + ~print:var_get_low + ~default + ~update:(fun ?context x old_x -> x @ old_x) + ?help + extra + in + + fun () -> + var_expand (var_get_low (var_get_lst env)) + + + let var_redefine + ?hide + ?dump + ?short_desc + ?cli + ?arg_help + ?group + name + dflt = + if Schema.mem schema name then + begin + (* TODO: look suspsicious, we want to memorize dflt not dflt () *) + Schema.set schema env ~context:ODefault name (dflt ()); + fun () -> var_get name + end + else + begin + var_define + ?hide + ?dump + ?short_desc + ?cli + ?arg_help + ?group + name + dflt + end + + + let var_ignore (e: unit -> string) = () + + + let print_hidden = + var_define + ~hide:true + ~dump:false + ~cli:CLIAuto + ~arg_help:"Print even non-printable variable. (debug)" + "print_hidden" + (fun () -> "false") + + + let var_all () = + List.rev + (Schema.fold + (fun acc nm def _ -> + if not def.hide || bool_of_string (print_hidden ()) then + nm :: acc + else + acc) + [] + schema) + + + let default_filename = + BaseEnvLight.default_filename + + + let load ?allow_empty ?filename () = + env_from_file := BaseEnvLight.load ?allow_empty ?filename () + + + let unload () = + env_from_file := MapString.empty; + Data.clear env + + + let dump ?(filename=default_filename) () = + let chn = + open_out_bin filename + in + let output nm value = + Printf.fprintf chn "%s=%S\n" nm value + in + let mp_todo = + (* Dump data from schema *) + Schema.fold + (fun mp_todo nm def _ -> + if def.dump then + begin + try + let value = + Schema.get + schema + env + nm + in + output nm value + with Not_set _ -> + () + end; + MapString.remove nm mp_todo) + !env_from_file + schema + in + (* Dump data defined outside of schema *) + MapString.iter output mp_todo; + + (* End of the dump *) + close_out chn + + + let print () = + let printable_vars = + Schema.fold + (fun acc nm def short_descr_opt -> + if not def.hide || bool_of_string (print_hidden ()) then + begin + try + let value = + Schema.get + schema + env + nm + in + let txt = + match short_descr_opt with + | Some s -> s () + | None -> nm + in + (txt, value) :: acc + with Not_set _ -> + acc + end + else + acc) + [] + schema + in + let max_length = + List.fold_left max 0 + (List.rev_map String.length + (List.rev_map fst printable_vars)) + in + let dot_pad str = + String.make ((max_length - (String.length str)) + 3) '.' + in + + Printf.printf "\nConfiguration: \n"; + List.iter + (fun (name, value) -> + Printf.printf "%s: %s %s\n" name (dot_pad name) value) + (List.rev printable_vars); + Printf.printf "\n%!" + + + let args () = + let arg_concat = + OASISUtils.varname_concat ~hyphen:'-' + in + [ + "--override", + Arg.Tuple + ( + let rvr = ref "" + in + let rvl = ref "" + in + [ + Arg.Set_string rvr; + Arg.Set_string rvl; + Arg.Unit + (fun () -> + Schema.set + schema + env + ~context:OCommandLine + !rvr + !rvl) + ] + ), + "var+val Override any configuration variable."; + + ] + @ + List.flatten + (Schema.fold + (fun acc name def short_descr_opt -> + let var_set s = + Schema.set + schema + env + ~context:OCommandLine + name + s + in + + let arg_name = + OASISUtils.varname_of_string ~hyphen:'-' name + in + + let hlp = + match short_descr_opt with + | Some txt -> txt () + | None -> "" + in + + let arg_hlp = + match def.arg_help with + | Some s -> s + | None -> "str" + in + + let default_value = + try + Printf.sprintf + (f_ " [%s]") + (Schema.get + schema + env + name) + with Not_set _ -> + "" + in + + let args = + match def.cli with + | CLINone -> + [] + | CLIAuto -> + [ + arg_concat "--" arg_name, + Arg.String var_set, + Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value + ] + | CLIWith -> + [ + arg_concat "--with-" arg_name, + Arg.String var_set, + Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value + ] + | CLIEnable -> + let dflt = + if default_value = " [true]" then + s_ " [default: enabled]" + else + s_ " [default: disabled]" + in + [ + arg_concat "--enable-" arg_name, + Arg.Unit (fun () -> var_set "true"), + Printf.sprintf (f_ " %s%s") hlp dflt; + + arg_concat "--disable-" arg_name, + Arg.Unit (fun () -> var_set "false"), + Printf.sprintf (f_ " %s%s") hlp dflt + ] + | CLIUser lst -> + lst + in + args :: acc) + [] + schema) +end + +module BaseArgExt = struct +(* # 22 "src/base/BaseArgExt.ml" *) + + + open OASISUtils + open OASISGettext + + + let parse argv args = + (* Simulate command line for Arg *) + let current = + ref 0 + in + + try + Arg.parse_argv + ~current:current + (Array.concat [[|"none"|]; argv]) + (Arg.align args) + (failwithf (f_ "Don't know what to do with arguments: '%s'")) + (s_ "configure options:") + with + | Arg.Help txt -> + print_endline txt; + exit 0 + | Arg.Bad txt -> + prerr_endline txt; + exit 1 +end + +module BaseCheck = struct +(* # 22 "src/base/BaseCheck.ml" *) + + + open BaseEnv + open BaseMessage + open OASISUtils + open OASISGettext + + + let prog_best prg prg_lst = + var_redefine + prg + (fun () -> + let alternate = + List.fold_left + (fun res e -> + match res with + | Some _ -> + res + | None -> + try + Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) + with Not_found -> + None) + None + prg_lst + in + match alternate with + | Some prg -> prg + | None -> raise Not_found) + + + let prog prg = + prog_best prg [prg] + + + let prog_opt prg = + prog_best prg [prg^".opt"; prg] + + + let ocamlfind = + prog "ocamlfind" + + + let version + var_prefix + cmp + fversion + () = + (* Really compare version provided *) + let var = + var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) + in + var_redefine + ~hide:true + var + (fun () -> + let version_str = + match fversion () with + | "[Distributed with OCaml]" -> + begin + try + (var_get "ocaml_version") + with Not_found -> + warning + (f_ "Variable ocaml_version not defined, fallback \ + to default"); + Sys.ocaml_version + end + | res -> + res + in + let version = + OASISVersion.version_of_string version_str + in + if OASISVersion.comparator_apply version cmp then + version_str + else + failwithf + (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") + var_prefix + (OASISVersion.string_of_comparator cmp) + version_str) + () + + + let package_version pkg = + OASISExec.run_read_one_line ~ctxt:!BaseContext.default + (ocamlfind ()) + ["query"; "-format"; "%v"; pkg] + + + let package ?version_comparator pkg () = + let var = + OASISUtils.varname_concat + "pkg_" + (OASISUtils.varname_of_string pkg) + in + let findlib_dir pkg = + let dir = + OASISExec.run_read_one_line ~ctxt:!BaseContext.default + (ocamlfind ()) + ["query"; "-format"; "%d"; pkg] + in + if Sys.file_exists dir && Sys.is_directory dir then + dir + else + failwithf + (f_ "When looking for findlib package %s, \ + directory %s return doesn't exist") + pkg dir + in + let vl = + var_redefine + var + (fun () -> findlib_dir pkg) + () + in + ( + match version_comparator with + | Some ver_cmp -> + ignore + (version + var + ver_cmp + (fun _ -> package_version pkg) + ()) + | None -> + () + ); + vl +end + +module BaseOCamlcConfig = struct +(* # 22 "src/base/BaseOCamlcConfig.ml" *) + + + open BaseEnv + open OASISUtils + open OASISGettext + + + module SMap = Map.Make(String) + + + let ocamlc = + BaseCheck.prog_opt "ocamlc" + + + let ocamlc_config_map = + (* Map name to value for ocamlc -config output + (name ^": "^value) + *) + let rec split_field mp lst = + match lst with + | line :: tl -> + let mp = + try + let pos_semicolon = + String.index line ':' + in + if pos_semicolon > 1 then + ( + let name = + String.sub line 0 pos_semicolon + in + let linelen = + String.length line + in + let value = + if linelen > pos_semicolon + 2 then + String.sub + line + (pos_semicolon + 2) + (linelen - pos_semicolon - 2) + else + "" + in + SMap.add name value mp + ) + else + ( + mp + ) + with Not_found -> + ( + mp + ) + in + split_field mp tl + | [] -> + mp + in + + let cache = + lazy + (var_protect + (Marshal.to_string + (split_field + SMap.empty + (OASISExec.run_read_output + ~ctxt:!BaseContext.default + (ocamlc ()) ["-config"])) + [])) + in + var_redefine + "ocamlc_config_map" + ~hide:true + ~dump:false + (fun () -> + (* TODO: update if ocamlc change !!! *) + Lazy.force cache) + + + let var_define nm = + (* Extract data from ocamlc -config *) + let avlbl_config_get () = + Marshal.from_string + (ocamlc_config_map ()) + 0 + in + let chop_version_suffix s = + try + String.sub s 0 (String.index s '+') + with _ -> + s + in + + let nm_config, value_config = + match nm with + | "ocaml_version" -> + "version", chop_version_suffix + | _ -> nm, (fun x -> x) + in + var_redefine + nm + (fun () -> + try + let map = + avlbl_config_get () + in + let value = + SMap.find nm_config map + in + value_config value + with Not_found -> + failwithf + (f_ "Cannot find field '%s' in '%s -config' output") + nm + (ocamlc ())) + +end + +module BaseStandardVar = struct +(* # 22 "src/base/BaseStandardVar.ml" *) + + + open OASISGettext + open OASISTypes + open OASISExpr + open BaseCheck + open BaseEnv + + + let ocamlfind = BaseCheck.ocamlfind + let ocamlc = BaseOCamlcConfig.ocamlc + let ocamlopt = prog_opt "ocamlopt" + let ocamlbuild = prog "ocamlbuild" + + + (**/**) + let rpkg = + ref None + + + let pkg_get () = + match !rpkg with + | Some pkg -> pkg + | None -> failwith (s_ "OASIS Package is not set") + + + let var_cond = ref [] + + + let var_define_cond ~since_version f dflt = + let holder = ref (fun () -> dflt) in + let since_version = + OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) + in + var_cond := + (fun ver -> + if OASISVersion.comparator_apply ver since_version then + holder := f ()) :: !var_cond; + fun () -> !holder () + + + (**/**) + + + let pkg_name = + var_define + ~short_desc:(fun () -> s_ "Package name") + "pkg_name" + (fun () -> (pkg_get ()).name) + + + let pkg_version = + var_define + ~short_desc:(fun () -> s_ "Package version") + "pkg_version" + (fun () -> + (OASISVersion.string_of_version (pkg_get ()).version)) + + + let c = BaseOCamlcConfig.var_define + + + let os_type = c "os_type" + let system = c "system" + let architecture = c "architecture" + let ccomp_type = c "ccomp_type" + let ocaml_version = c "ocaml_version" + + + (* TODO: Check standard variable presence at runtime *) + + + let standard_library_default = c "standard_library_default" + let standard_library = c "standard_library" + let standard_runtime = c "standard_runtime" + let bytecomp_c_compiler = c "bytecomp_c_compiler" + let native_c_compiler = c "native_c_compiler" + let model = c "model" + let ext_obj = c "ext_obj" + let ext_asm = c "ext_asm" + let ext_lib = c "ext_lib" + let ext_dll = c "ext_dll" + let default_executable_name = c "default_executable_name" + let systhread_supported = c "systhread_supported" + + + let flexlink = + BaseCheck.prog "flexlink" + + + let flexdll_version = + var_define + ~short_desc:(fun () -> "FlexDLL version (Win32)") + "flexdll_version" + (fun () -> + let lst = + OASISExec.run_read_output ~ctxt:!BaseContext.default + (flexlink ()) ["-help"] + in + match lst with + | line :: _ -> + Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) + | [] -> + raise Not_found) + + + (**/**) + let p name hlp dflt = + var_define + ~short_desc:hlp + ~cli:CLIAuto + ~arg_help:"dir" + name + dflt + + + let (/) a b = + if os_type () = Sys.os_type then + Filename.concat a b + else if os_type () = "Unix" then + OASISUnixPath.concat a b + else + OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") + (os_type ()) + (**/**) + + + let prefix = + p "prefix" + (fun () -> s_ "Install architecture-independent files dir") + (fun () -> + match os_type () with + | "Win32" -> + let program_files = + Sys.getenv "PROGRAMFILES" + in + program_files/(pkg_name ()) + | _ -> + "/usr/local") + + + let exec_prefix = + p "exec_prefix" + (fun () -> s_ "Install architecture-dependent files in dir") + (fun () -> "$prefix") + + + let bindir = + p "bindir" + (fun () -> s_ "User executables") + (fun () -> "$exec_prefix"/"bin") + + + let sbindir = + p "sbindir" + (fun () -> s_ "System admin executables") + (fun () -> "$exec_prefix"/"sbin") + + + let libexecdir = + p "libexecdir" + (fun () -> s_ "Program executables") + (fun () -> "$exec_prefix"/"libexec") + + + let sysconfdir = + p "sysconfdir" + (fun () -> s_ "Read-only single-machine data") + (fun () -> "$prefix"/"etc") + + + let sharedstatedir = + p "sharedstatedir" + (fun () -> s_ "Modifiable architecture-independent data") + (fun () -> "$prefix"/"com") + + + let localstatedir = + p "localstatedir" + (fun () -> s_ "Modifiable single-machine data") + (fun () -> "$prefix"/"var") + + + let libdir = + p "libdir" + (fun () -> s_ "Object code libraries") + (fun () -> "$exec_prefix"/"lib") + + + let datarootdir = + p "datarootdir" + (fun () -> s_ "Read-only arch-independent data root") + (fun () -> "$prefix"/"share") + + + let datadir = + p "datadir" + (fun () -> s_ "Read-only architecture-independent data") + (fun () -> "$datarootdir") + + + let infodir = + p "infodir" + (fun () -> s_ "Info documentation") + (fun () -> "$datarootdir"/"info") + + + let localedir = + p "localedir" + (fun () -> s_ "Locale-dependent data") + (fun () -> "$datarootdir"/"locale") + + + let mandir = + p "mandir" + (fun () -> s_ "Man documentation") + (fun () -> "$datarootdir"/"man") + + + let docdir = + p "docdir" + (fun () -> s_ "Documentation root") + (fun () -> "$datarootdir"/"doc"/"$pkg_name") + + + let htmldir = + p "htmldir" + (fun () -> s_ "HTML documentation") + (fun () -> "$docdir") + + + let dvidir = + p "dvidir" + (fun () -> s_ "DVI documentation") + (fun () -> "$docdir") + + + let pdfdir = + p "pdfdir" + (fun () -> s_ "PDF documentation") + (fun () -> "$docdir") + + + let psdir = + p "psdir" + (fun () -> s_ "PS documentation") + (fun () -> "$docdir") + + + let destdir = + p "destdir" + (fun () -> s_ "Prepend a path when installing package") + (fun () -> + raise + (PropList.Not_set + ("destdir", + Some (s_ "undefined by construct")))) + + + let findlib_version = + var_define + "findlib_version" + (fun () -> + BaseCheck.package_version "findlib") + + + let is_native = + var_define + "is_native" + (fun () -> + try + let _s: string = + ocamlopt () + in + "true" + with PropList.Not_set _ -> + let _s: string = + ocamlc () + in + "false") + + + let ext_program = + var_define + "suffix_program" + (fun () -> + match os_type () with + | "Win32" | "Cygwin" -> ".exe" + | _ -> "") + + + let rm = + var_define + ~short_desc:(fun () -> s_ "Remove a file.") + "rm" + (fun () -> + match os_type () with + | "Win32" -> "del" + | _ -> "rm -f") + + + let rmdir = + var_define + ~short_desc:(fun () -> s_ "Remove a directory.") + "rmdir" + (fun () -> + match os_type () with + | "Win32" -> "rd" + | _ -> "rm -rf") + + + let debug = + var_define + ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") + ~cli:CLIEnable + "debug" + (fun () -> "true") + + + let profile = + var_define + ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") + ~cli:CLIEnable + "profile" + (fun () -> "false") + + + let tests = + var_define_cond ~since_version:"0.3" + (fun () -> + var_define + ~short_desc:(fun () -> + s_ "Compile tests executable and library and run them") + ~cli:CLIEnable + "tests" + (fun () -> "false")) + "true" + + + let docs = + var_define_cond ~since_version:"0.3" + (fun () -> + var_define + ~short_desc:(fun () -> s_ "Create documentations") + ~cli:CLIEnable + "docs" + (fun () -> "true")) + "true" + + + let native_dynlink = + var_define + ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") + ~cli:CLINone + "native_dynlink" + (fun () -> + let res = + let ocaml_lt_312 () = + OASISVersion.comparator_apply + (OASISVersion.version_of_string (ocaml_version ())) + (OASISVersion.VLesser + (OASISVersion.version_of_string "3.12.0")) + in + let flexdll_lt_030 () = + OASISVersion.comparator_apply + (OASISVersion.version_of_string (flexdll_version ())) + (OASISVersion.VLesser + (OASISVersion.version_of_string "0.30")) + in + let has_native_dynlink = + let ocamlfind = ocamlfind () in + try + let fn = + OASISExec.run_read_one_line + ~ctxt:!BaseContext.default + ocamlfind + ["query"; "-predicates"; "native"; "dynlink"; + "-format"; "%d/%a"] + in + Sys.file_exists fn + with _ -> + false + in + if not has_native_dynlink then + false + else if ocaml_lt_312 () then + false + else if (os_type () = "Win32" || os_type () = "Cygwin") + && flexdll_lt_030 () then + begin + BaseMessage.warning + (f_ ".cmxs generation disabled because FlexDLL needs to be \ + at least 0.30. Please upgrade FlexDLL from %s to 0.30.") + (flexdll_version ()); + false + end + else + true + in + string_of_bool res) + + + let init pkg = + rpkg := Some pkg; + List.iter (fun f -> f pkg.oasis_version) !var_cond + +end + +module BaseFileAB = struct +(* # 22 "src/base/BaseFileAB.ml" *) + + + open BaseEnv + open OASISGettext + open BaseMessage + + + let to_filename fn = + let fn = + OASISHostPath.of_unix fn + in + if not (Filename.check_suffix fn ".ab") then + warning + (f_ "File '%s' doesn't have '.ab' extension") + fn; + Filename.chop_extension fn + + + let replace fn_lst = + let buff = + Buffer.create 13 + in + List.iter + (fun fn -> + let fn = + OASISHostPath.of_unix fn + in + let chn_in = + open_in fn + in + let chn_out = + open_out (to_filename fn) + in + ( + try + while true do + Buffer.add_string buff (var_expand (input_line chn_in)); + Buffer.add_char buff '\n' + done + with End_of_file -> + () + ); + Buffer.output_buffer chn_out buff; + Buffer.clear buff; + close_in chn_in; + close_out chn_out) + fn_lst +end + +module BaseLog = struct +(* # 22 "src/base/BaseLog.ml" *) + + + open OASISUtils + + + let default_filename = + Filename.concat + (Filename.dirname BaseEnv.default_filename) + "setup.log" + + + module SetTupleString = + Set.Make + (struct + type t = string * string + let compare (s11, s12) (s21, s22) = + match String.compare s11 s21 with + | 0 -> String.compare s12 s22 + | n -> n + end) + + + let load () = + if Sys.file_exists default_filename then + begin + let chn = + open_in default_filename + in + let scbuf = + Scanf.Scanning.from_file default_filename + in + let rec read_aux (st, lst) = + if not (Scanf.Scanning.end_of_input scbuf) then + begin + let acc = + try + Scanf.bscanf scbuf "%S %S\n" + (fun e d -> + let t = + e, d + in + if SetTupleString.mem t st then + st, lst + else + SetTupleString.add t st, + t :: lst) + with Scanf.Scan_failure _ -> + failwith + (Scanf.bscanf scbuf + "%l" + (fun line -> + Printf.sprintf + "Malformed log file '%s' at line %d" + default_filename + line)) + in + read_aux acc + end + else + begin + close_in chn; + List.rev lst + end + in + read_aux (SetTupleString.empty, []) + end + else + begin + [] + end + + + let register event data = + let chn_out = + open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename + in + Printf.fprintf chn_out "%S %S\n" event data; + close_out chn_out + + + let unregister event data = + if Sys.file_exists default_filename then + begin + let lst = + load () + in + let chn_out = + open_out default_filename + in + let write_something = + ref false + in + List.iter + (fun (e, d) -> + if e <> event || d <> data then + begin + write_something := true; + Printf.fprintf chn_out "%S %S\n" e d + end) + lst; + close_out chn_out; + if not !write_something then + Sys.remove default_filename + end + + + let filter events = + let st_events = + List.fold_left + (fun st e -> + SetString.add e st) + SetString.empty + events + in + List.filter + (fun (e, _) -> SetString.mem e st_events) + (load ()) + + + let exists event data = + List.exists + (fun v -> (event, data) = v) + (load ()) +end + +module BaseBuilt = struct +(* # 22 "src/base/BaseBuilt.ml" *) + + + open OASISTypes + open OASISGettext + open BaseStandardVar + open BaseMessage + + + type t = + | BExec (* Executable *) + | BExecLib (* Library coming with executable *) + | BLib (* Library *) + | BObj (* Library *) + | BDoc (* Document *) + + + let to_log_event_file t nm = + "built_"^ + (match t with + | BExec -> "exec" + | BExecLib -> "exec_lib" + | BLib -> "lib" + | BObj -> "obj" + | BDoc -> "doc")^ + "_"^nm + + + let to_log_event_done t nm = + "is_"^(to_log_event_file t nm) + + + let register t nm lst = + BaseLog.register + (to_log_event_done t nm) + "true"; + List.iter + (fun alt -> + let registered = + List.fold_left + (fun registered fn -> + if OASISFileUtil.file_exists_case fn then + begin + BaseLog.register + (to_log_event_file t nm) + (if Filename.is_relative fn then + Filename.concat (Sys.getcwd ()) fn + else + fn); + true + end + else + registered) + false + alt + in + if not registered then + warning + (f_ "Cannot find an existing alternative files among: %s") + (String.concat (s_ ", ") alt)) + lst + + + let unregister t nm = + List.iter + (fun (e, d) -> + BaseLog.unregister e d) + (BaseLog.filter + [to_log_event_file t nm; + to_log_event_done t nm]) + + + let fold t nm f acc = + List.fold_left + (fun acc (_, fn) -> + if OASISFileUtil.file_exists_case fn then + begin + f acc fn + end + else + begin + warning + (f_ "File '%s' has been marked as built \ + for %s but doesn't exist") + fn + (Printf.sprintf + (match t with + | BExec | BExecLib -> + (f_ "executable %s") + | BLib -> + (f_ "library %s") + | BObj -> + (f_ "object %s") + | BDoc -> + (f_ "documentation %s")) + nm); + acc + end) + acc + (BaseLog.filter + [to_log_event_file t nm]) + + + let is_built t nm = + List.fold_left + (fun is_built (_, d) -> + (try + bool_of_string d + with _ -> + false)) + false + (BaseLog.filter + [to_log_event_done t nm]) + + + let of_executable ffn (cs, bs, exec) = + let unix_exec_is, unix_dll_opt = + OASISExecutable.unix_exec_is + (cs, bs, exec) + (fun () -> + bool_of_string + (is_native ())) + ext_dll + ext_program + in + let evs = + (BExec, cs.cs_name, [[ffn unix_exec_is]]) + :: + (match unix_dll_opt with + | Some fn -> + [BExecLib, cs.cs_name, [[ffn fn]]] + | None -> + []) + in + evs, + unix_exec_is, + unix_dll_opt + + + let of_library ffn (cs, bs, lib) = + let unix_lst = + OASISLibrary.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 ())) + ~has_native_dynlink:(bool_of_string (native_dynlink ())) + ~ext_lib:(ext_lib ()) + ~ext_dll:(ext_dll ()) + (cs, bs, lib) + in + let evs = + [BLib, + cs.cs_name, + List.map (List.map ffn) unix_lst] + 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 +(* # 22 "src/base/BaseCustom.ml" *) + + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISGettext + + + let run cmd args extra_args = + OASISExec.run ~ctxt:!BaseContext.default ~quote:false + (var_expand cmd) + (List.map + var_expand + (args @ (Array.to_list extra_args))) + + + let hook ?(failsafe=false) cstm f e = + let optional_command lst = + let printer = + function + | Some (cmd, args) -> String.concat " " (cmd :: args) + | None -> s_ "No command" + in + match + var_choose + ~name:(s_ "Pre/Post Command") + ~printer + lst with + | Some (cmd, args) -> + begin + try + run cmd args [||] + with e when failsafe -> + warning + (f_ "Command '%s' fail with error: %s") + (String.concat " " (cmd :: args)) + (match e with + | Failure msg -> msg + | e -> Printexc.to_string e) + end + | None -> + () + in + let res = + optional_command cstm.pre_command; + f e + in + optional_command cstm.post_command; + res +end + +module BaseDynVar = struct +(* # 22 "src/base/BaseDynVar.ml" *) + + + open OASISTypes + open OASISGettext + open BaseEnv + open BaseBuilt + + + let init pkg = + (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) + (* TODO: provide compile option for library libary_byte_args_VARNAME... *) + List.iter + (function + | Executable (cs, bs, exec) -> + if var_choose bs.bs_build then + var_ignore + (var_redefine + (* We don't save this variable *) + ~dump:false + ~short_desc:(fun () -> + Printf.sprintf + (f_ "Filename of executable '%s'") + cs.cs_name) + (OASISUtils.varname_of_string cs.cs_name) + (fun () -> + let fn_opt = + fold + BExec cs.cs_name + (fun _ fn -> Some fn) + None + in + match fn_opt with + | Some fn -> fn + | None -> + raise + (PropList.Not_set + (cs.cs_name, + Some (Printf.sprintf + (f_ "Executable '%s' not yet built.") + cs.cs_name))))) + + | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> + ()) + pkg.sections +end + +module BaseTest = struct +(* # 22 "src/base/BaseTest.ml" *) + + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISExpr + open OASISGettext + + + let test lst pkg extra_args = + + let one_test (failure, n) (test_plugin, cs, test) = + if var_choose + ~name:(Printf.sprintf + (f_ "test %s run") + cs.cs_name) + ~printer:string_of_bool + test.test_run then + begin + let () = + info (f_ "Running test '%s'") cs.cs_name + in + let back_cwd = + match test.test_working_directory with + | Some dir -> + let cwd = + Sys.getcwd () + in + let chdir d = + info (f_ "Changing directory to '%s'") d; + Sys.chdir d + in + chdir dir; + fun () -> chdir cwd + + | None -> + fun () -> () + in + try + let failure_percent = + BaseCustom.hook + test.test_custom + (test_plugin pkg (cs, test)) + extra_args + in + back_cwd (); + (failure_percent +. failure, n + 1) + with e -> + begin + back_cwd (); + raise e + end + end + else + begin + info (f_ "Skipping test '%s'") cs.cs_name; + (failure, n) + end + in + let failed, n = + List.fold_left + one_test + (0.0, 0) + lst + in + let failure_percent = + if n = 0 then + 0.0 + else + failed /. (float_of_int n) + in + let msg = + Printf.sprintf + (f_ "Tests had a %.2f%% failure rate") + (100. *. failure_percent) + in + if failure_percent > 0.0 then + failwith msg + else + info "%s" msg; + + (* Possible explanation why the tests where not run. *) + if OASISFeatures.package_test OASISFeatures.flag_tests pkg && + not (bool_of_string (BaseStandardVar.tests ())) && + lst <> [] then + BaseMessage.warning + "Tests are turned off, consider enabling with \ + 'ocaml setup.ml -configure --enable-tests'" +end + +module BaseDoc = struct +(* # 22 "src/base/BaseDoc.ml" *) + + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISGettext + + + let doc lst pkg extra_args = + + let one_doc (doc_plugin, cs, doc) = + if var_choose + ~name:(Printf.sprintf + (f_ "documentation %s build") + cs.cs_name) + ~printer:string_of_bool + doc.doc_build then + begin + info (f_ "Building documentation '%s'") cs.cs_name; + BaseCustom.hook + doc.doc_custom + (doc_plugin pkg (cs, doc)) + extra_args + end + in + List.iter one_doc lst; + + if OASISFeatures.package_test OASISFeatures.flag_docs pkg && + not (bool_of_string (BaseStandardVar.docs ())) && + lst <> [] then + BaseMessage.warning + "Docs are turned off, consider enabling with \ + 'ocaml setup.ml -configure --enable-docs'" +end + +module BaseSetup = struct +(* # 22 "src/base/BaseSetup.ml" *) + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISSection + open OASISGettext + open OASISUtils + + + type std_args_fun = + package -> string array -> unit + + + type ('a, 'b) section_args_fun = + name * (package -> (common_section * 'a) -> string array -> 'b) + + + type t = + { + configure: std_args_fun; + build: std_args_fun; + doc: ((doc, unit) section_args_fun) list; + test: ((test, float) section_args_fun) list; + install: std_args_fun; + uninstall: std_args_fun; + clean: std_args_fun list; + clean_doc: (doc, unit) section_args_fun list; + clean_test: (test, unit) section_args_fun list; + distclean: std_args_fun list; + distclean_doc: (doc, unit) section_args_fun list; + distclean_test: (test, unit) section_args_fun list; + package: package; + oasis_fn: string option; + oasis_version: string; + oasis_digest: Digest.t option; + oasis_exec: string option; + oasis_setup_args: string list; + setup_update: bool; + } + + + (* Associate a plugin function with data from package *) + let join_plugin_sections filter_map lst = + List.rev + (List.fold_left + (fun acc sct -> + match filter_map sct with + | Some e -> + e :: acc + | None -> + acc) + [] + lst) + + + (* Search for plugin data associated with a section name *) + let lookup_plugin_section plugin action nm lst = + try + List.assoc nm lst + with Not_found -> + failwithf + (f_ "Cannot find plugin %s matching section %s for %s action") + plugin + nm + action + + + let configure t args = + (* Run configure *) + BaseCustom.hook + t.package.conf_custom + (fun () -> + (* Reload if preconf has changed it *) + begin + try + unload (); + load (); + with _ -> + () + end; + + (* Run plugin's configure *) + t.configure t.package args; + + (* Dump to allow postconf to change it *) + dump ()) + (); + + (* Reload environment *) + unload (); + load (); + + (* Save environment *) + print (); + + (* Replace data in file *) + BaseFileAB.replace t.package.files_ab + + + let build t args = + BaseCustom.hook + t.package.build_custom + (t.build t.package) + args + + + let doc t args = + BaseDoc.doc + (join_plugin_sections + (function + | Doc (cs, e) -> + Some + (lookup_plugin_section + "documentation" + (s_ "build") + cs.cs_name + t.doc, + cs, + e) + | _ -> + None) + t.package.sections) + t.package + args + + + let test t args = + BaseTest.test + (join_plugin_sections + (function + | Test (cs, e) -> + Some + (lookup_plugin_section + "test" + (s_ "run") + cs.cs_name + t.test, + cs, + e) + | _ -> + None) + t.package.sections) + t.package + args + + + let all t args = + let rno_doc = + ref false + in + let rno_test = + ref false + in + let arg_rest = + ref [] + in + Arg.parse_argv + ~current:(ref 0) + (Array.of_list + ((Sys.executable_name^" all") :: + (Array.to_list args))) + [ + "-no-doc", + Arg.Set rno_doc, + s_ "Don't run doc target"; + + "-no-test", + Arg.Set rno_test, + s_ "Don't run test target"; + + "--", + Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), + s_ "All arguments for configure."; + ] + (failwithf (f_ "Don't know what to do with '%s'")) + ""; + + info "Running configure step"; + configure t (Array.of_list (List.rev !arg_rest)); + + info "Running build step"; + build t [||]; + + (* Load setup.log dynamic variables *) + BaseDynVar.init t.package; + + if not !rno_doc then + begin + info "Running doc step"; + doc t [||]; + end + else + begin + info "Skipping doc step" + end; + + if not !rno_test then + begin + info "Running test step"; + test t [||] + end + else + begin + info "Skipping test step" + end + + + let install t args = + BaseCustom.hook + t.package.install_custom + (t.install t.package) + args + + + let uninstall t args = + BaseCustom.hook + t.package.uninstall_custom + (t.uninstall t.package) + args + + + let reinstall t args = + uninstall t args; + install t args + + + let clean, distclean = + let failsafe f a = + try + f a + with e -> + warning + (f_ "Action fail with error: %s") + (match e with + | Failure msg -> msg + | e -> Printexc.to_string e) + in + + let generic_clean t cstm mains docs tests args = + BaseCustom.hook + ~failsafe:true + cstm + (fun () -> + (* Clean section *) + List.iter + (function + | Test (cs, test) -> + let f = + try + List.assoc cs.cs_name tests + with Not_found -> + fun _ _ _ -> () + in + failsafe + (f t.package (cs, test)) + args + | Doc (cs, doc) -> + let f = + try + List.assoc cs.cs_name docs + with Not_found -> + fun _ _ _ -> () + in + failsafe + (f t.package (cs, doc)) + args + | Library _ + | Object _ + | Executable _ + | Flag _ + | SrcRepo _ -> + ()) + t.package.sections; + (* Clean whole package *) + List.iter + (fun f -> + failsafe + (f t.package) + args) + mains) + () + in + + let clean t args = + generic_clean + t + t.package.clean_custom + t.clean + t.clean_doc + t.clean_test + args + in + + let distclean t args = + (* Call clean *) + clean t args; + + (* Call distclean code *) + generic_clean + t + t.package.distclean_custom + t.distclean + t.distclean_doc + t.distclean_test + args; + + (* Remove generated file *) + List.iter + (fun fn -> + if Sys.file_exists fn then + begin + info (f_ "Remove '%s'") fn; + Sys.remove fn + end) + (BaseEnv.default_filename + :: + BaseLog.default_filename + :: + (List.rev_map BaseFileAB.to_filename t.package.files_ab)) + in + + clean, distclean + + + let version t _ = + print_endline t.oasis_version + + + let update_setup_ml, no_update_setup_ml_cli = + let b = ref true in + b, + ("-no-update-setup-ml", + Arg.Clear b, + s_ " Don't try to update setup.ml, even if _oasis has changed.") + + + let default_oasis_fn = "_oasis" + + + let update_setup_ml t = + let oasis_fn = + match t.oasis_fn with + | Some fn -> fn + | None -> default_oasis_fn + in + let oasis_exec = + match t.oasis_exec with + | Some fn -> fn + | None -> "oasis" + in + let ocaml = + Sys.executable_name + in + let setup_ml, args = + match Array.to_list Sys.argv with + | setup_ml :: args -> + setup_ml, args + | [] -> + failwith + (s_ "Expecting non-empty command line arguments.") + in + let ocaml, setup_ml = + if Sys.executable_name = Sys.argv.(0) then + (* We are not running in standard mode, probably the script + * is precompiled. + *) + "ocaml", "setup.ml" + else + ocaml, setup_ml + in + let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in + let do_update () = + let oasis_exec_version = + OASISExec.run_read_one_line + ~ctxt:!BaseContext.default + ~f_exit_code: + (function + | 0 -> + () + | 1 -> + failwithf + (f_ "Executable '%s' is probably an old version \ + of oasis (< 0.3.0), please update to version \ + v%s.") + oasis_exec t.oasis_version + | 127 -> + failwithf + (f_ "Cannot find executable '%s', please install \ + oasis v%s.") + oasis_exec t.oasis_version + | n -> + failwithf + (f_ "Command '%s version' exited with code %d.") + oasis_exec n) + oasis_exec ["version"] + in + if OASISVersion.comparator_apply + (OASISVersion.version_of_string oasis_exec_version) + (OASISVersion.VGreaterEqual + (OASISVersion.version_of_string t.oasis_version)) then + begin + (* We have a version >= for the executable oasis, proceed with + * update. + *) + (* TODO: delegate this check to 'oasis setup'. *) + if Sys.os_type = "Win32" then + failwithf + (f_ "It is not possible to update the running script \ + setup.ml on Windows. Please update setup.ml by \ + running '%s'.") + (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) + else + begin + OASISExec.run + ~ctxt:!BaseContext.default + ~f_exit_code: + (function + | 0 -> + () + | n -> + failwithf + (f_ "Unable to update setup.ml using '%s', \ + please fix the problem and retry.") + oasis_exec) + oasis_exec ("setup" :: t.oasis_setup_args); + OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) + end + end + else + failwithf + (f_ "The version of '%s' (v%s) doesn't match the version of \ + oasis used to generate the %s file. Please install at \ + least oasis v%s.") + oasis_exec oasis_exec_version setup_ml t.oasis_version + in + + if !update_setup_ml then + begin + try + match t.oasis_digest with + | Some dgst -> + if Sys.file_exists oasis_fn && + dgst <> Digest.file default_oasis_fn then + begin + do_update (); + true + end + else + false + | None -> + false + with e -> + error + (f_ "Error when updating setup.ml. If you want to avoid this error, \ + you can bypass the update of %s by running '%s %s %s %s'") + setup_ml ocaml setup_ml no_update_setup_ml_cli + (String.concat " " args); + raise e + end + else + false + + + let setup t = + let catch_exn = + ref true + in + try + let act_ref = + ref (fun _ -> + failwithf + (f_ "No action defined, run '%s %s -help'") + Sys.executable_name + Sys.argv.(0)) + + in + let extra_args_ref = + ref [] + in + let allow_empty_env_ref = + ref false + in + let arg_handle ?(allow_empty_env=false) act = + Arg.Tuple + [ + Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); + + Arg.Unit + (fun () -> + allow_empty_env_ref := allow_empty_env; + act_ref := act); + ] + in + + Arg.parse + (Arg.align + ([ + "-configure", + arg_handle ~allow_empty_env:true configure, + s_ "[options*] Configure the whole build process."; + + "-build", + arg_handle build, + s_ "[options*] Build executables and libraries."; + + "-doc", + arg_handle doc, + s_ "[options*] Build documents."; + + "-test", + arg_handle test, + s_ "[options*] Run tests."; + + "-all", + arg_handle ~allow_empty_env:true all, + s_ "[options*] Run configure, build, doc and test targets."; + + "-install", + arg_handle install, + s_ "[options*] Install libraries, data, executables \ + and documents."; + + "-uninstall", + arg_handle uninstall, + s_ "[options*] Uninstall libraries, data, executables \ + and documents."; + + "-reinstall", + arg_handle reinstall, + s_ "[options*] Uninstall and install libraries, data, \ + executables and documents."; + + "-clean", + arg_handle ~allow_empty_env:true clean, + s_ "[options*] Clean files generated by a build."; + + "-distclean", + arg_handle ~allow_empty_env:true distclean, + s_ "[options*] Clean files generated by a build and configure."; + + "-version", + arg_handle ~allow_empty_env:true version, + s_ " Display version of OASIS used to generate this setup.ml."; + + "-no-catch-exn", + Arg.Clear catch_exn, + s_ " Don't catch exception, useful for debugging."; + ] + @ + (if t.setup_update then + [no_update_setup_ml_cli] + else + []) + @ (BaseContext.args ()))) + (failwithf (f_ "Don't know what to do with '%s'")) + (s_ "Setup and run build process current package\n"); + + (* Build initial environment *) + load ~allow_empty:!allow_empty_env_ref (); + + (** Initialize flags *) + List.iter + (function + | Flag (cs, {flag_description = hlp; + flag_default = choices}) -> + begin + let apply ?short_desc () = + var_ignore + (var_define + ~cli:CLIEnable + ?short_desc + (OASISUtils.varname_of_string cs.cs_name) + (fun () -> + string_of_bool + (var_choose + ~name:(Printf.sprintf + (f_ "default value of flag %s") + cs.cs_name) + ~printer:string_of_bool + choices))) + in + match hlp with + | Some hlp -> + apply ~short_desc:(fun () -> hlp) () + | None -> + apply () + end + | _ -> + ()) + t.package.sections; + + BaseStandardVar.init t.package; + + BaseDynVar.init t.package; + + if t.setup_update && update_setup_ml t then + () + else + !act_ref t (Array.of_list (List.rev !extra_args_ref)) + + with e when !catch_exn -> + error "%s" (Printexc.to_string e); + exit 1 + + +end + + +# 5394 "setup.ml" +module InternalConfigurePlugin = struct +(* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) + + + (** Configure using internal scheme + @author Sylvain Le Gall + *) + + + open BaseEnv + open OASISTypes + open OASISUtils + open OASISGettext + open BaseMessage + + + (** Configure build using provided series of check to be done + * and then output corresponding file. + *) + let configure pkg argv = + let var_ignore_eval var = let _s: string = var () in () in + let errors = ref SetString.empty in + let buff = Buffer.create 13 in + + let add_errors fmt = + Printf.kbprintf + (fun b -> + errors := SetString.add (Buffer.contents b) !errors; + Buffer.clear b) + buff + fmt + in + + let warn_exception e = + warning "%s" (Printexc.to_string e) + in + + (* Check tools *) + let check_tools lst = + List.iter + (function + | ExternalTool tool -> + begin + try + var_ignore_eval (BaseCheck.prog tool) + with e -> + warn_exception e; + add_errors (f_ "Cannot find external tool '%s'") tool + end + | InternalExecutable nm1 -> + (* Check that matching tool is built *) + List.iter + (function + | Executable ({cs_name = nm2}, + {bs_build = build}, + _) when nm1 = nm2 -> + if not (var_choose build) then + add_errors + (f_ "Cannot find buildable internal executable \ + '%s' when checking build depends") + nm1 + | _ -> + ()) + pkg.sections) + lst + in + + let build_checks sct bs = + if var_choose bs.bs_build then + begin + if bs.bs_compiled_object = Native then + begin + try + var_ignore_eval BaseStandardVar.ocamlopt + with e -> + warn_exception e; + add_errors + (f_ "Section %s requires native compilation") + (OASISSection.string_of_section sct) + end; + + (* Check tools *) + check_tools bs.bs_build_tools; + + (* Check depends *) + List.iter + (function + | FindlibPackage (findlib_pkg, version_comparator) -> + begin + try + var_ignore_eval + (BaseCheck.package ?version_comparator findlib_pkg) + with e -> + warn_exception e; + match version_comparator with + | None -> + add_errors + (f_ "Cannot find findlib package %s") + findlib_pkg + | Some ver_cmp -> + add_errors + (f_ "Cannot find findlib package %s (%s)") + findlib_pkg + (OASISVersion.string_of_comparator ver_cmp) + end + | InternalLibrary nm1 -> + (* Check that matching library is built *) + List.iter + (function + | Library ({cs_name = nm2}, + {bs_build = build}, + _) when nm1 = nm2 -> + if not (var_choose build) then + add_errors + (f_ "Cannot find buildable internal library \ + '%s' when checking build depends") + nm1 + | _ -> + ()) + pkg.sections) + bs.bs_build_depends + end + in + + (* Parse command line *) + BaseArgExt.parse argv (BaseEnv.args ()); + + (* OCaml version *) + begin + match pkg.ocaml_version with + | Some ver_cmp -> + begin + try + var_ignore_eval + (BaseCheck.version + "ocaml" + ver_cmp + BaseStandardVar.ocaml_version) + with e -> + warn_exception e; + add_errors + (f_ "OCaml version %s doesn't match version constraint %s") + (BaseStandardVar.ocaml_version ()) + (OASISVersion.string_of_comparator ver_cmp) + end + | None -> + () + end; + + (* Findlib version *) + begin + match pkg.findlib_version with + | Some ver_cmp -> + begin + try + var_ignore_eval + (BaseCheck.version + "findlib" + ver_cmp + BaseStandardVar.findlib_version) + with e -> + warn_exception e; + add_errors + (f_ "Findlib version %s doesn't match version constraint %s") + (BaseStandardVar.findlib_version ()) + (OASISVersion.string_of_comparator ver_cmp) + end + | 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" || + BaseStandardVar.os_type () = "Cygwin" then + begin + try + var_ignore_eval BaseStandardVar.flexlink + with e -> + warn_exception e; + add_errors (f_ "Cannot find 'flexlink'") + end; + + (* Check build depends *) + List.iter + (function + | Executable (_, bs, _) + | Library (_, bs, _) as sct -> + build_checks sct bs + | Doc (_, doc) -> + if var_choose doc.doc_build then + check_tools doc.doc_build_tools + | Test (_, test) -> + if var_choose test.test_run then + check_tools test.test_tools + | _ -> + ()) + pkg.sections; + + (* Check if we need native dynlink (presence of libraries that compile to + * native) + *) + begin + let has_cmxa = + List.exists + (function + | Library (_, bs, _) -> + var_choose bs.bs_build && + (bs.bs_compiled_object = Native || + (bs.bs_compiled_object = Best && + bool_of_string (BaseStandardVar.is_native ()))) + | _ -> + false) + pkg.sections + in + if has_cmxa then + var_ignore_eval BaseStandardVar.native_dynlink + end; + + (* Check errors *) + if SetString.empty != !errors then + begin + List.iter + (fun e -> error "%s" e) + (SetString.elements !errors); + failwithf + (fn_ + "%d configuration error" + "%d configuration errors" + (SetString.cardinal !errors)) + (SetString.cardinal !errors) + end + + +end + +module InternalInstallPlugin = struct +(* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *) + + + (** Install using internal scheme + @author Sylvain Le Gall + *) + + + open BaseEnv + open BaseStandardVar + open BaseMessage + open OASISTypes + open OASISFindlib + open OASISGettext + open OASISUtils + + + let exec_hook = + ref (fun (cs, bs, exec) -> cs, bs, exec) + + + 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) + + + let install_file_ev = + "install-file" + + + let install_dir_ev = + "install-dir" + + + let install_findlib_ev = + "install-findlib" + + + let win32_max_command_line_length = 8000 + + + let split_install_command ocamlfind findlib_name meta files = + if Sys.os_type = "Win32" then + (* Arguments for the first command: *) + let first_args = ["install"; findlib_name; meta] in + (* Arguments for remaining commands: *) + let other_args = ["install"; findlib_name; "-add"] in + (* Extract as much files as possible from [files], [len] is + the current command line length: *) + let rec get_files len acc files = + match files with + | [] -> + (List.rev acc, []) + | file :: rest -> + let len = len + 1 + String.length file in + if len > win32_max_command_line_length then + (List.rev acc, files) + else + get_files len (file :: acc) rest + in + (* Split the command into several commands. *) + let rec split args files = + match files with + | [] -> + [] + | _ -> + (* Length of "ocamlfind install [META|-add]" *) + let len = + List.fold_left + (fun len arg -> + len + 1 (* for the space *) + String.length arg) + (String.length ocamlfind) + args + in + match get_files len [] files with + | ([], _) -> + failwith (s_ "Command line too long.") + | (firsts, others) -> + let cmd = args @ firsts in + (* Use -add for remaining commands: *) + let () = + let findlib_ge_132 = + OASISVersion.comparator_apply + (OASISVersion.version_of_string + (BaseStandardVar.findlib_version ())) + (OASISVersion.VGreaterEqual + (OASISVersion.version_of_string "1.3.2")) + in + if not findlib_ge_132 then + failwithf + (f_ "Installing the library %s require to use the \ + flag '-add' of ocamlfind because the command \ + line is too long. This flag is only available \ + for findlib 1.3.2. Please upgrade findlib from \ + %s to 1.3.2") + findlib_name (BaseStandardVar.findlib_version ()) + in + let cmds = split other_args others in + cmd :: cmds + in + (* The first command does not use -add: *) + split first_args files + else + ["install" :: findlib_name :: meta :: files] + + + let install pkg argv = + + let in_destdir = + try + let destdir = + destdir () + in + (* Practically speaking destdir is prepended + * at the beginning of the target filename + *) + fun fn -> destdir^fn + with PropList.Not_set _ -> + fun fn -> fn + in + + let install_file ?tgt_fn src_file envdir = + let tgt_dir = + in_destdir (envdir ()) + in + let tgt_file = + Filename.concat + tgt_dir + (match tgt_fn with + | Some fn -> + fn + | None -> + Filename.basename src_file) + in + (* Create target directory if needed *) + OASISFileUtil.mkdir_parent + ~ctxt:!BaseContext.default + (fun dn -> + info (f_ "Creating directory '%s'") dn; + BaseLog.register install_dir_ev dn) + tgt_dir; + + (* Really install files *) + info (f_ "Copying file '%s' to '%s'") src_file tgt_file; + OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file; + BaseLog.register install_file_ev tgt_file + in + + (* Install data into defined directory *) + let install_data srcdir lst tgtdir = + let tgtdir = + OASISHostPath.of_unix (var_expand tgtdir) + in + List.iter + (fun (src, tgt_opt) -> + let real_srcs = + OASISFileUtil.glob + ~ctxt:!BaseContext.default + (Filename.concat srcdir src) + in + if real_srcs = [] then + failwithf + (f_ "Wildcard '%s' doesn't match any files") + src; + List.iter + (fun fn -> + install_file + fn + (fun () -> + match tgt_opt with + | Some s -> + OASISHostPath.of_unix (var_expand s) + | None -> + tgtdir)) + real_srcs) + lst + in + + (** Install all libraries *) + let install_libs pkg = + + let files_of_library (f_data, acc) data_lib = + let cs, bs, lib, lib_extra = + !lib_hook data_lib + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then + begin + let acc = + (* Start with acc + lib_extra *) + List.rev_append lib_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 library %s") + modul cs.cs_name; + acc + end) + acc + lib.lib_modules + in + + let acc = + (* Get generated files *) + BaseBuilt.fold + BaseBuilt.BLib + cs.cs_name + (fun acc fn -> fn :: acc) + acc + in + + let f_data () = + (* Install data associated with the library *) + 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 + 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 *) + let install_group_lib grp = + (* Iterate through all group nodes *) + let rec install_group_lib_aux data_and_files grp = + let data_and_files, children = + match grp with + | Container (_, children) -> + data_and_files, 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 + data_and_files + children + in + + (* Findlib name of the root library *) + let findlib_name = + findlib_of_group grp + in + + (* Determine root library *) + let root_lib = + root_of_group grp + in + + (* All files to install for this library *) + let f_data, files = + install_group_lib_aux (ignore, []) grp + in + + (* Really install, if there is something to install *) + if files = [] then + begin + warning + (f_ "Nothing to install for findlib library '%s'") + findlib_name + end + else + begin + let meta = + (* Search META file *) + let _, bs, _ = + root_lib + in + let res = + Filename.concat bs.bs_path "META" + in + if not (OASISFileUtil.file_exists_case res) then + failwithf + (f_ "Cannot find file '%s' for findlib library %s") + res + findlib_name; + res + in + let files = + (* Make filename shorter to avoid hitting command max line length + * too early, esp. on Windows. + *) + let remove_prefix p n = + let plen = String.length p in + let nlen = String.length n in + if plen <= nlen && String.sub n 0 plen = p then + begin + let fn_sep = + if Sys.os_type = "Win32" then + '\\' + else + '/' + in + let cutpoint = plen + + (if plen < nlen && n.[plen] = fn_sep then + 1 + else + 0) + in + String.sub n cutpoint (nlen - cutpoint) + end + else + n + in + List.map (remove_prefix (Sys.getcwd ())) files + in + info + (f_ "Installing findlib library '%s'") + findlib_name; + let ocamlfind = ocamlfind () in + let commands = + split_install_command + ocamlfind + findlib_name + meta + files + in + List.iter + (OASISExec.run ~ctxt:!BaseContext.default ocamlfind) + commands; + BaseLog.register install_findlib_ev findlib_name + end; + + (* Install data files *) + f_data (); + + in + + let group_libs, _, _ = + findlib_mapping pkg + in + + (* We install libraries in groups *) + List.iter install_group_lib group_libs + in + + let install_execs pkg = + let install_exec data_exec = + let cs, bs, exec = + !exec_hook data_exec + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then + begin + let exec_libdir () = + Filename.concat + (libdir ()) + pkg.name + in + BaseBuilt.fold + BaseBuilt.BExec + cs.cs_name + (fun () fn -> + install_file + ~tgt_fn:(cs.cs_name ^ ext_program ()) + fn + bindir) + (); + BaseBuilt.fold + BaseBuilt.BExecLib + cs.cs_name + (fun () fn -> + install_file + fn + exec_libdir) + (); + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name) + end + in + List.iter + (function + | Executable (cs, bs, exec)-> + install_exec (cs, bs, exec) + | _ -> + ()) + pkg.sections + in + + let install_docs pkg = + let install_doc data = + let cs, doc = + !doc_hook data + in + if var_choose doc.doc_install && + BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then + begin + let tgt_dir = + OASISHostPath.of_unix (var_expand doc.doc_install_dir) + in + BaseBuilt.fold + BaseBuilt.BDoc + cs.cs_name + (fun () fn -> + install_file + fn + (fun () -> tgt_dir)) + (); + install_data + Filename.current_dir_name + doc.doc_data_files + doc.doc_install_dir + end + in + List.iter + (function + | Doc (cs, doc) -> + install_doc (cs, doc) + | _ -> + ()) + pkg.sections + in + + install_libs pkg; + install_execs pkg; + install_docs pkg + + + (* Uninstall already installed data *) + let uninstall _ argv = + List.iter + (fun (ev, data) -> + if ev = install_file_ev then + begin + if OASISFileUtil.file_exists_case data then + begin + info + (f_ "Removing file '%s'") + data; + Sys.remove data + end + else + begin + warning + (f_ "File '%s' doesn't exist anymore") + data + end + end + else if ev = install_dir_ev then + begin + if Sys.file_exists data && Sys.is_directory data then + begin + if Sys.readdir data = [||] then + begin + info + (f_ "Removing directory '%s'") + data; + OASISFileUtil.rmdir ~ctxt:!BaseContext.default data + end + else + begin + warning + (f_ "Directory '%s' is not empty (%s)") + data + (String.concat + ", " + (Array.to_list + (Sys.readdir data))) + end + end + else + begin + warning + (f_ "Directory '%s' doesn't exist anymore") + data + end + end + else if ev = install_findlib_ev then + begin + info (f_ "Removing findlib library '%s'") data; + OASISExec.run ~ctxt:!BaseContext.default + (ocamlfind ()) ["remove"; data] + end + else + failwithf (f_ "Unknown log event '%s'") ev; + BaseLog.unregister ev data) + (* We process event in reverse order *) + (List.rev + (BaseLog.filter + [install_file_ev; + install_dir_ev; + install_findlib_ev])) + + +end + + +# 6243 "setup.ml" +module OCamlbuildCommon = struct +(* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) + + + (** Functions common to OCamlbuild build and doc plugin + *) + + + open OASISGettext + open BaseEnv + open BaseStandardVar + open OASISTypes + + + + + type extra_args = string list + + + let ocamlbuild_clean_ev = "ocamlbuild-clean" + + + let ocamlbuildflags = + var_define + ~short_desc:(fun () -> "OCamlbuild additional flags") + "ocamlbuildflags" + (fun () -> "") + + + (** Fix special arguments depending on environment *) + let fix_args args extra_argv = + List.flatten + [ + if (os_type ()) = "Win32" then + [ + "-classic-display"; + "-no-log"; + "-no-links"; + "-install-lib-dir"; + (Filename.concat (standard_library ()) "ocamlbuild") + ] + else + []; + + if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then + [ + "-byte-plugin" + ] + else + []; + args; + + if bool_of_string (debug ()) then + ["-tag"; "debug"] + else + []; + + if bool_of_string (profile ()) then + ["-tag"; "profile"] + else + []; + + OASISString.nsplit (ocamlbuildflags ()) ' '; + + Array.to_list extra_argv; + ] + + + (** Run 'ocamlbuild -clean' if not already done *) + let run_clean extra_argv = + let extra_cli = + String.concat " " (Array.to_list extra_argv) + in + (* Run if never called with these args *) + if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then + begin + OASISExec.run ~ctxt:!BaseContext.default + (ocamlbuild ()) (fix_args ["-clean"] extra_argv); + BaseLog.register ocamlbuild_clean_ev extra_cli; + at_exit + (fun () -> + try + BaseLog.unregister ocamlbuild_clean_ev extra_cli + with _ -> + ()) + end + + + (** Run ocamlbuild, unregister all clean events *) + let run_ocamlbuild args extra_argv = + (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html + *) + OASISExec.run ~ctxt:!BaseContext.default + (ocamlbuild ()) (fix_args args extra_argv); + (* Remove any clean event, we must run it again *) + List.iter + (fun (e, d) -> BaseLog.unregister e d) + (BaseLog.filter [ocamlbuild_clean_ev]) + + + (** Determine real build directory *) + let build_dir extra_argv = + let rec search_args dir = + function + | "-build-dir" :: dir :: tl -> + search_args dir tl + | _ :: tl -> + search_args dir tl + | [] -> + dir + in + search_args "_build" (fix_args [] extra_argv) + + +end + +module OCamlbuildPlugin = struct +(* # 22 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) + + + (** Build using ocamlbuild + @author Sylvain Le Gall + *) + + + open OASISTypes + open OASISGettext + open OASISUtils + open OASISString + open BaseEnv + open OCamlbuildCommon + open BaseStandardVar + open BaseMessage + + + + + + let cond_targets_hook = + ref (fun lst -> lst) + + + let build extra_args pkg argv = + (* Return the filename in build directory *) + let in_build_dir fn = + Filename.concat + (build_dir argv) + fn + in + + (* Return the unix filename in host build directory *) + let in_build_dir_of_unix fn = + in_build_dir (OASISHostPath.of_unix fn) + in + + let cond_targets = + List.fold_left + (fun acc -> + function + | Library (cs, bs, lib) when var_choose bs.bs_build -> + begin + let evs, unix_files = + BaseBuilt.of_library + in_build_dir_of_unix + (cs, bs, lib) + in + + let tgts = + List.flatten + (List.filter + (fun l -> l <> []) + (List.map + (List.filter + (fun fn -> + ends_with ~what:".cma" fn + || ends_with ~what:".cmxs" fn + || ends_with ~what:".cmxa" fn + || ends_with ~what:(ext_lib ()) fn + || ends_with ~what:(ext_dll ()) fn)) + unix_files)) + in + + match tgts with + | _ :: _ -> + (evs, tgts) :: acc + | [] -> + failwithf + (f_ "No possible ocamlbuild targets for library %s") + 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 = + BaseBuilt.of_executable + in_build_dir_of_unix + (cs, bs, exec) + in + + let target ext = + let unix_tgt = + (OASISUnixPath.concat + bs.bs_path + (OASISUnixPath.chop_extension + exec.exec_main_is))^ext + in + let evs = + (* Fix evs, we want to use the unix_tgt, without copying *) + List.map + (function + | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> + BaseBuilt.BExec, nm, + [[in_build_dir_of_unix unix_tgt]] + | ev -> + ev) + evs + in + evs, [unix_tgt] + in + + (* Add executable *) + let acc = + 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 _ + | SrcRepo _ | Flag _ | Doc _ -> + acc) + [] + (* Keep the pkg.sections ordered *) + (List.rev pkg.sections); + in + + (* Check and register built files *) + let check_and_register (bt, bnm, lst) = + List.iter + (fun fns -> + if not (List.exists OASISFileUtil.file_exists_case fns) then + failwithf + (fn_ + "Expected built file %s doesn't exist." + "None of expected built files %s exists." + (List.length fns)) + (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) + lst; + (BaseBuilt.register bt bnm lst) + in + + (* Run the hook *) + let cond_targets = !cond_targets_hook cond_targets in + + (* Run a list of target... *) + run_ocamlbuild (List.flatten (List.map snd cond_targets) @ extra_args) argv; + (* ... and register events *) + List.iter check_and_register (List.flatten (List.map fst cond_targets)) + + + let clean pkg extra_args = + run_clean extra_args; + List.iter + (function + | Library (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BLib cs.cs_name + | Executable (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; + BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name + | _ -> + ()) + pkg.sections + + +end + +module OCamlbuildDocPlugin = struct +(* # 22 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) + + + (* Create documentation using ocamlbuild .odocl files + @author Sylvain Le Gall + *) + + + open OASISTypes + open OASISGettext + open OASISMessage + open OCamlbuildCommon + open BaseStandardVar + + + + + type run_t = + { + extra_args: string list; + run_path: unix_filename; + } + + + let doc_build run pkg (cs, doc) argv = + let index_html = + OASISUnixPath.make + [ + run.run_path; + cs.cs_name^".docdir"; + "index.html"; + ] + in + let tgt_dir = + OASISHostPath.make + [ + build_dir argv; + OASISHostPath.of_unix run.run_path; + cs.cs_name^".docdir"; + ] + in + run_ocamlbuild (index_html :: run.extra_args) argv; + List.iter + (fun glb -> + BaseBuilt.register + BaseBuilt.BDoc + cs.cs_name + [OASISFileUtil.glob ~ctxt:!BaseContext.default + (Filename.concat tgt_dir glb)]) + ["*.html"; "*.css"] + + + let doc_clean run pkg (cs, doc) argv = + run_clean argv; + BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name + + +end + + +# 6616 "setup.ml" +module CustomPlugin = struct +(* # 22 "src/plugins/custom/CustomPlugin.ml" *) + + + (** Generate custom configure/build/doc/test/install system + @author + *) + + + open BaseEnv + open OASISGettext + open OASISTypes + + + + + + type t = + { + cmd_main: command_line conditional; + cmd_clean: (command_line option) conditional; + cmd_distclean: (command_line option) conditional; + } + + + let run = BaseCustom.run + + + let main t _ extra_args = + let cmd, args = + var_choose + ~name:(s_ "main command") + t.cmd_main + in + run cmd args extra_args + + + let clean t pkg extra_args = + match var_choose t.cmd_clean with + | Some (cmd, args) -> + run cmd args extra_args + | _ -> + () + + + let distclean t pkg extra_args = + match var_choose t.cmd_distclean with + | Some (cmd, args) -> + run cmd args extra_args + | _ -> + () + + + module Build = + struct + let main t pkg extra_args = + main t pkg extra_args; + List.iter + (fun sct -> + let evs = + match sct with + | Library (cs, bs, lib) when var_choose bs.bs_build -> + begin + let evs, _ = + BaseBuilt.of_library + OASISHostPath.of_unix + (cs, bs, lib) + in + evs + end + | Executable (cs, bs, exec) when var_choose bs.bs_build -> + begin + let evs, _, _ = + BaseBuilt.of_executable + OASISHostPath.of_unix + (cs, bs, exec) + in + evs + end + | _ -> + [] + in + List.iter + (fun (bt, bnm, lst) -> BaseBuilt.register bt bnm lst) + evs) + pkg.sections + + let clean t pkg extra_args = + clean t pkg extra_args; + (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild + * considering moving this to BaseSetup? + *) + List.iter + (function + | Library (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BLib cs.cs_name + | Executable (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; + BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name + | _ -> + ()) + pkg.sections + + let distclean t pkg extra_args = + distclean t pkg extra_args + end + + + module Test = + struct + let main t pkg (cs, test) extra_args = + try + main t pkg extra_args; + 0.0 + with Failure s -> + BaseMessage.warning + (f_ "Test '%s' fails: %s") + cs.cs_name + s; + 1.0 + + let clean t pkg (cs, test) extra_args = + clean t pkg extra_args + + let distclean t pkg (cs, test) extra_args = + distclean t pkg extra_args + end + + + module Doc = + struct + let main t pkg (cs, _) extra_args = + main t pkg extra_args; + BaseBuilt.register BaseBuilt.BDoc cs.cs_name [] + + let clean t pkg (cs, _) extra_args = + clean t pkg extra_args; + BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name + + let distclean t pkg (cs, _) extra_args = + distclean t pkg extra_args + end + + +end + + +# 6764 "setup.ml" +open OASISTypes;; + +let setup_t = + { + BaseSetup.configure = InternalConfigurePlugin.configure; + build = OCamlbuildPlugin.build []; + test = + [ + ("test_networkd", + CustomPlugin.Test.main + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$network_test", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)] + }) + ]; + doc = []; + install = InternalInstallPlugin.install; + uninstall = InternalInstallPlugin.uninstall; + clean = [OCamlbuildPlugin.clean]; + clean_test = + [ + ("test_networkd", + CustomPlugin.Test.clean + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$network_test", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)] + }) + ]; + clean_doc = []; + distclean = []; + distclean_test = + [ + ("test_networkd", + CustomPlugin.Test.distclean + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$network_test", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)] + }) + ]; + distclean_doc = []; + package = + { + oasis_version = "0.3"; + ocaml_version = None; + findlib_version = None; + alpha_features = []; + beta_features = []; + name = "xcp-networkd"; + version = "0.9.4"; + license = + OASISLicense.DEP5License + (OASISLicense.DEP5Unit + { + OASISLicense.license = "LGPL"; + excption = Some "OCaml linking"; + version = OASISLicense.Version "2.1" + }); + license_file = None; + copyrights = []; + maintainers = []; + authors = ["Rob Hoes"]; + homepage = None; + synopsis = "XCP Network Daemon"; + description = None; + categories = []; + conf_type = (`Configure, "internal", Some "0.4"); + conf_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + build_type = (`Build, "ocamlbuild", Some "0.4"); + build_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + install_type = (`Install, "internal", Some "0.4"); + install_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + uninstall_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + clean_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + distclean_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + files_ab = []; + sections = + [ + Library + ({ + cs_name = "networklibs"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "lib"; + bs_compiled_object = Best; + bs_build_depends = + [ + FindlibPackage ("forkexec", None); + FindlibPackage ("stdext", None); + FindlibPackage ("threads", None); + FindlibPackage ("rpclib", None); + FindlibPackage ("stdext", None); + FindlibPackage ("xcp-inventory", None); + FindlibPackage ("xcp.network", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = ["link_stubs.c"; "netdev.h"]; + bs_data_files = []; + bs_ccopt = + [ + (OASISExpr.EBool true, + ["-Wno-unused-function"; "-g"; "-ggdb"]) + ]; + 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, [])] + }, + { + lib_modules = ["Network_config"; "Network_utils"]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = None; + lib_findlib_name = Some "network-libs"; + lib_findlib_containers = [] + }); + Executable + ({ + cs_name = "xcp_networkd"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "networkd"; + bs_compiled_object = Best; + bs_build_depends = + [ + FindlibPackage ("threads", None); + FindlibPackage ("rpclib", None); + FindlibPackage ("rpclib.unix", None); + FindlibPackage ("forkexec", None); + FindlibPackage ("stdext", None); + FindlibPackage ("xcp-inventory", None); + InternalLibrary "networklibs"; + FindlibPackage ("xen-api-client", None); + FindlibPackage ("xcp", None); + FindlibPackage ("xcp.network", 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 = "networkd.ml"}); + Executable + ({ + cs_name = "networkd_db"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "networkd_db"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "networklibs"; + FindlibPackage ("stdext", None); + FindlibPackage ("threads", None); + FindlibPackage ("xcp.network", 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 = "networkd_db.ml"}); + Executable + ({ + cs_name = "network_test"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "test"; + bs_compiled_object = Best; + bs_build_depends = + [ + FindlibPackage ("stdext", None); + FindlibPackage ("oUnit", None); + InternalLibrary "networklibs" + ]; + 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 = false; exec_main_is = "network_test.ml"}); + Test + ({ + cs_name = "test_networkd"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + test_type = (`Test, "custom", Some "0.4"); + test_command = + [(OASISExpr.EBool true, ("$network_test", []))]; + test_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + test_working_directory = Some "."; + test_run = + [ + (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); + (OASISExpr.EFlag "tests", false); + (OASISExpr.EAnd + (OASISExpr.EFlag "tests", + OASISExpr.EFlag "tests"), + true) + ]; + test_tools = [ExternalTool "ocamlbuild"] + }) + ]; + plugins = [(`Extra, "META", Some "0.2")]; + disable_oasis_section = []; + schema_data = PropList.Data.create (); + plugin_data = [] + }; + oasis_fn = Some "_oasis"; + oasis_version = "0.4.4"; + oasis_digest = Some "^\179\199[\222\\\135\148\248p\223z\230\242E9"; + oasis_exec = None; + oasis_setup_args = []; + setup_update = false + };; + +let setup () = BaseSetup.setup setup_t;; + +# 7051 "setup.ml" +(* OASIS_STOP *) +let () = setup ();; From a15a399e46714fc5d76b85978c4ae297aaa2cab5 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 6 Jun 2014 16:04:03 +0100 Subject: [PATCH 044/260] Update oasis Signed-off-by: Rob Hoes --- _oasis | 2 +- _tags | 4 +- myocamlbuild.ml | 47 ++++------ setup.ml | 237 +++++++++++++++--------------------------------- 4 files changed, 92 insertions(+), 198 deletions(-) diff --git a/_oasis b/_oasis index bf17b223b..88958d14f 100644 --- a/_oasis +++ b/_oasis @@ -22,7 +22,7 @@ Executable xcp_networkd MainIs: networkd.ml Custom: true Install: false - BuildDepends: threads, rpclib, rpclib.unix, forkexec, stdext, xcp-inventory, network-libs, xen-api-client, xcp, xcp.network + BuildDepends: threads, rpclib, rpclib.unix, forkexec, stdext, xcp-inventory, network-libs, xen-api-client, xcp, xcp.network, netlink Executable networkd_db CompiledObject: best diff --git a/_tags b/_tags index 34f629423..029f7bd59 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 6dce1a9a50f608514e51caf58ef0ebc9) +# DO NOT EDIT (digest: 25ce055fb4cc4259cfd4fd1e986a20f1) # 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 @@ -32,6 +32,7 @@ "lib/link_stubs.c": pkg_xcp.network # Executable xcp_networkd : pkg_forkexec +: pkg_netlink : pkg_rpclib : pkg_rpclib.unix : pkg_stdext @@ -42,6 +43,7 @@ : pkg_xen-api-client : use_networklibs : pkg_forkexec +: pkg_netlink : pkg_rpclib : pkg_rpclib.unix : pkg_stdext diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 8ec5d77b9..9ba62daf2 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 1b562e89c2fc3873269cda485f3abe87) *) +(* DO NOT EDIT (digest: b61c6662b23d9ed3268fd3f519fdb137) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) @@ -259,31 +259,6 @@ module MyOCamlbuildFindlib = struct Ocamlbuild_pack.Lexers.blank_sep_strings - let exec_from_conf exec = - let exec = - let env_filename = Pathname.basename BaseEnvLight.default_filename in - let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in - try - BaseEnvLight.var_get exec env - with Not_found -> - Printf.eprintf "W: Cannot get variable %s\n" exec; - exec - in - let fix_win32 str = - if Sys.os_type = "Win32" then begin - let buff = Buffer.create (String.length str) in - (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. - *) - String.iter - (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) - str; - Buffer.contents buff - end else begin - str - end - in - fix_win32 exec - let split s ch = let buf = Buffer.create 13 in let x = ref [] in @@ -311,7 +286,17 @@ module MyOCamlbuildFindlib = struct with Not_found -> s (* ocamlfind command *) - let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] + let ocamlfind x = + let ocamlfind_prog = + let env_filename = Pathname.basename BaseEnvLight.default_filename in + let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in + try + BaseEnvLight.var_get "ocamlfind" env + with Not_found -> + Printf.eprintf "W: Cannot get variable ocamlfind"; + "ocamlfind" + in + S[Sh ocamlfind_prog; x] (* This lists all supported packages. *) let find_packages () = @@ -340,7 +325,7 @@ module MyOCamlbuildFindlib = struct let dispatch = function - | After_options -> + | Before_options -> (* By using Before_options one let command line options have an higher * priority on the contrary using After_options will guarantee to have * the higher priority override default commands by ocamlfind ones *) @@ -491,7 +476,7 @@ module MyOCamlbuildBase = struct try opt := no_trailing_dot (BaseEnvLight.var_get var env) with Not_found -> - Printf.eprintf "W: Cannot get variable %s\n" var) + Printf.eprintf "W: Cannot get variable %s" var) [ Options.ext_obj, "ext_obj"; Options.ext_lib, "ext_lib"; @@ -591,7 +576,7 @@ module MyOCamlbuildBase = struct end -# 594 "myocamlbuild.ml" +# 579 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { @@ -620,6 +605,6 @@ let package_default = let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; -# 624 "myocamlbuild.ml" +# 609 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/setup.ml b/setup.ml index c274d211b..b66076247 100644 --- a/setup.ml +++ b/setup.ml @@ -1,9 +1,9 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 8a544e6f7b2bc3fb2f97d5be41f7b1aa) *) +(* DO NOT EDIT (digest: 4af85109009a4a9acf4da8dcb4c88f5b) *) (* - Regenerated by OASIS v0.4.4 + Regenerated by OASIS v0.4.2 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) @@ -258,62 +258,29 @@ module OASISUtils = struct open OASISGettext - module MapExt = - struct - module type S = - sig - include Map.S - val add_list: 'a t -> (key * 'a) list -> 'a t - val of_list: (key * 'a) list -> 'a t - val to_list: 'a t -> (key * 'a) list - end - - module Make (Ord: Map.OrderedType) = - struct - include Map.Make(Ord) - - let rec add_list t = - function - | (k, v) :: tl -> add_list (add k v t) tl - | [] -> t - - let of_list lst = add_list empty lst - - let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] - end - end + module MapString = Map.Make(String) - module MapString = MapExt.Make(String) + let map_string_of_assoc assoc = + List.fold_left + (fun acc (k, v) -> MapString.add k v acc) + MapString.empty + assoc - module SetExt = - struct - module type S = - sig - include Set.S - val add_list: t -> elt list -> t - val of_list: elt list -> t - val to_list: t -> elt list - end - - module Make (Ord: Set.OrderedType) = - struct - include Set.Make(Ord) - - let rec add_list t = - function - | e :: tl -> add_list (add e t) tl - | [] -> t + module SetString = Set.Make(String) - let of_list lst = add_list empty lst - let to_list = elements - end - end + let set_string_add_list st lst = + List.fold_left + (fun acc e -> SetString.add e acc) + st + lst - module SetString = SetExt.Make(String) + let set_string_of_list = + set_string_add_list + SetString.empty let compare_csl s1 s2 = @@ -333,7 +300,7 @@ module OASISUtils = struct end) module SetStringCsl = - SetExt.Make + Set.Make (struct type t = string let compare = compare_csl @@ -1080,21 +1047,6 @@ module OASISExpr = struct end -module OASISText = struct -(* # 22 "src/oasis/OASISText.ml" *) - - - - type elt = - | Para of string - | Verbatim of string - | BlankLine - - - type t = elt list - -end - module OASISTypes = struct (* # 22 "src/oasis/OASISTypes.ml" *) @@ -1327,42 +1279,41 @@ module OASISTypes = struct type package = { - oasis_version: OASISVersion.t; - ocaml_version: OASISVersion.comparator option; - findlib_version: OASISVersion.comparator option; - alpha_features: string list; - beta_features: string list; - name: package_name; - version: OASISVersion.t; - license: OASISLicense.t; - license_file: unix_filename option; - copyrights: string list; - maintainers: string list; - authors: string list; - homepage: url option; - synopsis: string; - description: OASISText.t option; - categories: url list; - - conf_type: [`Configure] plugin; - conf_custom: custom; - - build_type: [`Build] plugin; - build_custom: custom; - - install_type: [`Install] plugin; - install_custom: custom; - uninstall_custom: custom; - - clean_custom: custom; - distclean_custom: custom; - - files_ab: unix_filename list; - sections: section list; - plugins: [`Extra] plugin list; - disable_oasis_section: unix_filename list; - schema_data: PropList.Data.t; - plugin_data: plugin_data; + oasis_version: OASISVersion.t; + ocaml_version: OASISVersion.comparator option; + findlib_version: OASISVersion.comparator option; + alpha_features: string list; + beta_features: string list; + name: package_name; + version: OASISVersion.t; + license: OASISLicense.t; + license_file: unix_filename option; + copyrights: string list; + maintainers: string list; + authors: string list; + homepage: url option; + synopsis: string; + description: string option; + categories: url list; + + conf_type: [`Configure] plugin; + conf_custom: custom; + + build_type: [`Build] plugin; + build_custom: custom; + + install_type: [`Install] plugin; + install_custom: custom; + uninstall_custom: custom; + + clean_custom: custom; + distclean_custom: custom; + + files_ab: unix_filename list; + sections: section list; + plugins: [`Extra] plugin list; + schema_data: PropList.Data.t; + plugin_data: plugin_data; } @@ -1416,24 +1367,6 @@ module OASISFeatures = struct let plugin_version plugin_kind plugin_name t = MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions - - let to_string t = - Printf.sprintf - "oasis_version: %s; alpha_features: %s; beta_features: %s; \ - plugins_version: %s" - (OASISVersion.string_of_version t.oasis_version) - (String.concat ", " t.alpha_features) - (String.concat ", " t.beta_features) - (String.concat ", " - (MapPlugin.fold - (fun (_, plg) ver_opt acc -> - (plg^ - (match ver_opt with - | Some v -> - " "^(OASISVersion.string_of_version v) - | None -> "")) - :: acc) - t.plugin_versions [])) end type origin = @@ -1474,17 +1407,6 @@ module OASISFeatures = struct let beta = InDev Beta - let to_string t = - Printf.sprintf - "feature: %s; plugin: %s; publication: %s" - t.name - (match t.plugin with - | None -> "" - | Some (_, nm, _) -> nm) - (match t.publication with - | InDev stage -> string_of_stage stage - | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) - let data_check t data origin = let no_message = "no message" in @@ -1717,18 +1639,6 @@ module OASISFeatures = struct create "dynrun_for_release" alpha (fun () -> s_ "Make '-setup-update dynamic' suitable for releasing project.") - - - let compiled_setup_ml = - create "compiled_setup_ml" alpha - (fun () -> - s_ "It compiles the setup.ml and speed-up actions done with it.") - - let disable_oasis_section = - create "disable_oasis_section" alpha - (fun () -> - s_ "Allows the OASIS section comments and digest to be omitted in \ - generated files.") end module OASISUnixPath = struct @@ -2817,17 +2727,14 @@ module OASISFileUtil = struct let rmdir ~ctxt tgt = - if Sys.readdir tgt = [||] then begin - match Sys.os_type with - | "Win32" -> - OASISExec.run ~ctxt "rd" [q tgt] - | _ -> - OASISExec.run ~ctxt "rm" ["-r"; q tgt] - end else begin - OASISMessage.error ~ctxt - (f_ "Cannot remove directory '%s': not empty.") - tgt - end + if Sys.readdir tgt = [||] then + begin + match Sys.os_type with + | "Win32" -> + OASISExec.run ~ctxt "rd" [q tgt] + | _ -> + OASISExec.run ~ctxt "rm" ["-r"; q tgt] + end let glob ~ctxt fn = @@ -2875,7 +2782,7 @@ module OASISFileUtil = struct end -# 2878 "setup.ml" +# 2785 "setup.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) @@ -2980,7 +2887,7 @@ module BaseEnvLight = struct end -# 2983 "setup.ml" +# 2890 "setup.ml" module BaseContext = struct (* # 22 "src/base/BaseContext.ml" *) @@ -5391,7 +5298,7 @@ module BaseSetup = struct end -# 5394 "setup.ml" +# 5301 "setup.ml" module InternalConfigurePlugin = struct (* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) @@ -6240,7 +6147,7 @@ module InternalInstallPlugin = struct end -# 6243 "setup.ml" +# 6150 "setup.ml" module OCamlbuildCommon = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) @@ -6613,7 +6520,7 @@ module OCamlbuildDocPlugin = struct end -# 6616 "setup.ml" +# 6523 "setup.ml" module CustomPlugin = struct (* # 22 "src/plugins/custom/CustomPlugin.ml" *) @@ -6761,7 +6668,7 @@ module CustomPlugin = struct end -# 6764 "setup.ml" +# 6671 "setup.ml" open OASISTypes;; let setup_t = @@ -6934,7 +6841,8 @@ let setup_t = InternalLibrary "networklibs"; FindlibPackage ("xen-api-client", None); FindlibPackage ("xcp", None); - FindlibPackage ("xcp.network", None) + FindlibPackage ("xcp.network", None); + FindlibPackage ("netlink", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -7033,13 +6941,12 @@ let setup_t = }) ]; plugins = [(`Extra, "META", Some "0.2")]; - disable_oasis_section = []; schema_data = PropList.Data.create (); plugin_data = [] }; oasis_fn = Some "_oasis"; - oasis_version = "0.4.4"; - oasis_digest = Some "^\179\199[\222\\\135\148\248p\223z\230\242E9"; + oasis_version = "0.4.2"; + oasis_digest = Some "\r\232-\232\227fs7j\240\016\152\179\188\188\""; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7047,6 +6954,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7051 "setup.ml" +# 6958 "setup.ml" (* OASIS_STOP *) let () = setup ();; From a2a480f9a3f7d8717988319fe48ac11ddf9f908f Mon Sep 17 00:00:00 2001 From: Ravi Pandey Date: Fri, 13 Jun 2014 09:19:42 +0100 Subject: [PATCH 045/260] CA-137227: Checking xen-backend in link of /sys/class/net/*/device/driver to identify vifs Signed-off-by: Ravi Pandey --- lib/network_utils.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 90ab69791..1cbddb41d 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -86,9 +86,10 @@ module Sysfs = struct let is_physical name = try - let link = Unix.readlink (getpath name "device") in - (* filter out device symlinks which look like /../../../devices/xen-backend/vif- *) - not(List.mem "xen-backend" (String.split '/' link)) + let devpath = getpath name "device" in + let driver_link = Unix.readlink (devpath ^ "/driver") in + (* filter out symlinks under device/driver which look like /../../../devices/xen-backend/vif- *) + not(List.mem "xen-backend" (String.split '/' driver_link)) with _ -> false let get_carrier name = From aead1477089b7f559ee195e8feb9caa7eb918c58 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Fri, 27 Jun 2014 23:45:06 +0100 Subject: [PATCH 046/260] Don't let naughty dhcp servers trick us into setting default routes. Signed-off-by: Jon Ludlam --- lib/network_utils.ml | 18 ++++++++++++++++-- networkd/network_server.ml | 10 +--------- 2 files changed, 17 insertions(+), 11 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 1cbddb41d..7e5a2e392 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -470,7 +470,11 @@ module Dhclient = struct let generate_conf ?(ipv6=false) interface options = let minimal = ["subnet-mask"; "broadcast-address"; "time-offset"; "host-name"; "nis-domain"; "nis-servers"; "ntp-servers"; "interface-mtu"] in - let set_gateway = if List.mem `set_gateway options then ["routers"] else [] in + let set_gateway = + if List.mem (`gateway interface) options + then (debug "%s is the default gateway interface" interface; ["routers"]) + else (debug "%s is NOT the default gateway interface" interface; []) + in let set_dns = if List.mem `set_dns options then ["domain-name"; "domain-name-servers"] else [] in let request = minimal @ set_gateway @ set_dns in Printf.sprintf "interface \"%s\" {\n request %s;\n}\n" interface (String.concat ", " request) @@ -484,9 +488,19 @@ module Dhclient = struct Unixext.write_string_to_file (conf_file ~ipv6 interface) conf let start ?(ipv6=false) interface options = + (* If we have a gateway interface, pass it to dhclient-script via -e *) + (* This prevents the default route being set erroneously on CentOS *) + (* Normally this wouldn't happen as we're not requesting routers, *) + (* but some buggy DHCP servers ignore this *) + (* See CA-137892 *) + let gw_opt = List.fold_left + (fun l x -> + match x with + | `gateway y -> ["-e"; "GATEWAYDEV="^y] + | _ -> l) [] options in write_conf_file ~ipv6 interface options; let ipv6' = if ipv6 then ["-6"] else [] in - call_script ~log_successful_output:true dhclient (ipv6' @ ["-q"; + call_script ~log_successful_output:true dhclient (ipv6' @ gw_opt @ ["-q"; "-pf"; pid_file ~ipv6 interface; "-lf"; lease_file ~ipv6 interface; "-cf"; conf_file ~ipv6 interface; diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 969413d3c..63f7d7671 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -133,15 +133,7 @@ module Interface = struct Ip.flush_ip_addr name end | DHCP4 -> - let gateway = - if !config.gateway_interface = None || !config.gateway_interface = Some name then begin - debug "%s is the default gateway interface" name; - [`set_gateway] - end else begin - debug "%s is NOT the default gateway interface" name; - [] - end - in + let gateway = Opt.default [] (Opt.map (fun n -> [`gateway n]) !config.gateway_interface) in let dns = if !config.dns_interface = None || !config.dns_interface = Some name then begin debug "%s is the DNS interface" name; From c4efd3bb05ec613212029d05fe74105d063f79af Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Mon, 14 Jul 2014 15:25:32 +0100 Subject: [PATCH 047/260] Don't record RRDs for the "ovs-system" interface This started appearing in the recent single-datapath OVSes, but does not really add anything useful. Signed-off-by: Rob Hoes --- networkd/network_monitor_thread.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index 3a357b225..91b8605b9 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -115,7 +115,8 @@ let get_link_stats () = not(String.startswith "dummy" name) && not(String.startswith "xenbr" name) && not(String.startswith "xapi" name) && - not(String.startswith "eth" name && String.contains name '.') + not(String.startswith "eth" name && String.contains name '.') && + name <> "ovs-system" ) devs in Cache.free cache; From 60b65140b50434d4b97af891f5f72a69cc4f7022 Mon Sep 17 00:00:00 2001 From: Ravi Pandey Date: Fri, 1 Aug 2014 15:24:55 +0100 Subject: [PATCH 048/260] CA-137591: Removing all the interfaces before bringing the bridge down Signed-off-by: Ravi Pandey --- networkd/network_server.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 63f7d7671..ca412757e 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -528,6 +528,7 @@ module Bridge = struct remove_config name; List.iter (fun dev -> Interface.set_ipv4_conf () dbg ~name:dev ~conf:None4; + Brctl.destroy_port name dev; Interface.bring_down () dbg ~name:dev; if Linux_bonding.is_bond_device dev then Linux_bonding.remove_bond_master dev; From 6b6aa22086606af77fd34b9e37c0babbc139e6ca Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 8 Aug 2014 15:58:14 +0100 Subject: [PATCH 049/260] CA-140402: set max-idle to 5000ms on OVS Max-idle is an OVS setting that determines the idle timeout of flows in the kernel. Upstream OVS had reduced the timeout from 5000ms to 1500ms, causing kernel flows to be removed sooner. For flows that send packets with an interval that is a little larger than 1500ms, this means that every packet will result in an upcall to the OVS userspace. Tests have shown a relatively large impact on the dom0 CPU usage due to the reduced timeout. This patch puts the max-idle timeout back to 5000ms. Do this in xcp-networkd when it starts up. Signed-off-by: Rob Hoes --- lib/network_utils.ml | 6 ++++++ networkd/network_server.ml | 2 ++ 2 files changed, 8 insertions(+) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 7e5a2e392..01f6e89b5 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -663,6 +663,12 @@ module Ovs = struct nb_links with _ -> 0 + let set_max_idle t = + try + ignore (vsctl ["set"; "Open_vSwitch"; "."; Printf.sprintf "other_config:max-idle=%d" t]) + with _ -> + warn "Failed to set max-idle=%d on OVS" t + let handle_vlan_bug_workaround override bridge = (* This is a list of drivers that do support VLAN tx or rx acceleration, but * to which the VLAN bug workaround should not be applied. This could be diff --git a/networkd/network_server.ml b/networkd/network_server.ml index ca412757e..9c5f80238 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -769,6 +769,8 @@ let on_startup () = (* the following is best-effort *) read_config (); remove_centos_config (); + if !Bridge.kind = Openvswitch then + Ovs.set_max_idle 5000; Bridge.make_config () dbg ~conservative:true ~config:!config.bridge_config (); Interface.make_config () dbg ~conservative:true ~config:!config.interface_config (); (* If there is still a network.dbcache file, move it out of the way. *) From 7b85912bc3d81d3501a6dfcace9cfe7aa33411b9 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 23 Sep 2014 10:54:48 +0100 Subject: [PATCH 050/260] networkd: add Cisco UCS enic workaround check When on the Linux bridge backend and when the "enic" driver is loaded, we need to apply a workaround (implemented in the following commit). The enic driver is for Cisco UCS devices. The current driver adds VLAN0 headers to all incoming packets, which confuses certain guests OSes. The workaround constitutes added a VLAN0 Linux device to strip those headers again. The patch moves the "backend_kind" ref outside the Bridge module, and adds an "need_enic_workaround" function. Signed-off-by: Rob Hoes --- lib/network_utils.ml | 7 ++++++ networkd/network_server.ml | 49 ++++++++++++++++++++++---------------- 2 files changed, 35 insertions(+), 21 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 01f6e89b5..28f8b7f79 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -66,6 +66,13 @@ module Sysfs = struct let all = Array.to_list (Sys.readdir "/sys/class/net") in List.filter (fun name -> Sys.is_directory ("/sys/class/net/" ^ name)) all + let list_drivers () = + try + Array.to_list (Sys.readdir "/sys/bus/pci/drivers") + with _ -> + warn "Failed to obtain list of drivers from sysfs"; + [] + let getpath dev attr = Printf.sprintf "/sys/class/net/%s/%s" dev attr diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 9c5f80238..fc400f8d0 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -26,6 +26,7 @@ type context = unit let network_conf = ref "/etc/xcp/network.conf" let config : config_t ref = ref empty_config +let backend_kind = ref Openvswitch let legacy_management_interface_start () = try @@ -84,6 +85,13 @@ let set_dns_interface _ dbg ~name = debug "Setting DNS interface to %s" name; config := {!config with dns_interface = Some name} +(* The enic driver is for Cisco UCS devices. The current driver adds VLAN0 headers + * to all incoming packets, which confuses certain guests OSes. The workaround + * constitutes adding a VLAN0 Linux device to strip those headers again. + *) +let need_enic_workaround () = + !backend_kind = Bridge && List.mem "enic" (Sysfs.list_drivers ()) + module Interface = struct let get_config name = get_config !config.interface_config default_interface name @@ -378,7 +386,6 @@ module Interface = struct end module Bridge = struct - let kind = ref Openvswitch let add_default = ref [] let get_config name = @@ -394,25 +401,25 @@ module Bridge = struct try let backend = String.strip String.isspace (Unixext.string_of_file !network_conf) in match backend with - | "openvswitch" | "vswitch" -> kind := Openvswitch - | "bridge" -> kind := Bridge + | "openvswitch" | "vswitch" -> backend_kind := Openvswitch + | "bridge" -> backend_kind := Bridge | backend -> warn "Network backend unknown (%s). Falling back to Open vSwitch." backend; - kind := Openvswitch + backend_kind := Openvswitch with _ -> warn "Network-conf file not found. Falling back to Open vSwitch."; - kind := Openvswitch + backend_kind := Openvswitch let get_bond_links_up _ dbg ~name = Debug.with_thread_associated dbg (fun () -> - match !kind with + match !backend_kind with | Openvswitch -> Ovs.get_bond_links_up name | Bridge -> Proc.get_bond_links_up name ) () let get_all _ dbg () = Debug.with_thread_associated dbg (fun () -> - match !kind with + match !backend_kind with | Openvswitch -> Ovs.list_bridges () | Bridge -> Sysfs.get_all_bridges () ) () @@ -424,7 +431,7 @@ module Bridge = struct | Some (parent, vlan) -> Printf.sprintf " (VLAN %d on bridge %s)" vlan parent ); update_config name {(get_config name) with vlan; bridge_mac=mac; other_config}; - begin match !kind with + begin match !backend_kind with | Openvswitch -> let fail_mode = if not (List.mem_assoc "vswitch-controller-fail-mode" other_config) then @@ -499,7 +506,7 @@ module Bridge = struct let destroy _ dbg ?(force=false) ~name () = Debug.with_thread_associated dbg (fun () -> Interface.bring_down () dbg ~name; - match !kind with + match !backend_kind with | Openvswitch -> if Ovs.get_vlans name = [] || force then begin debug "Destroying bridge %s" name; @@ -543,12 +550,12 @@ module Bridge = struct let get_kind _ dbg () = Debug.with_thread_associated dbg (fun () -> - !kind + !backend_kind ) () let get_ports _ dbg ~name = Debug.with_thread_associated dbg (fun () -> - match !kind with + match !backend_kind with | Openvswitch -> Ovs.bridge_to_ports name | Bridge -> raise Not_implemented ) () @@ -559,14 +566,14 @@ module Bridge = struct let ports = List.concat (List.map (fun (_, {ports}) -> ports) !config.bridge_config) in List.map (fun (port, {interfaces}) -> port, interfaces) ports else - match !kind with + match !backend_kind with | Openvswitch -> List.concat (List.map Ovs.bridge_to_ports (Ovs.list_bridges ())) | Bridge -> raise Not_implemented ) () let get_bonds _ dbg ~name = Debug.with_thread_associated dbg (fun () -> - match !kind with + match !backend_kind with | Openvswitch -> Ovs.bridge_to_ports name | Bridge -> raise Not_implemented ) () @@ -578,21 +585,21 @@ module Bridge = struct let names = List.map (fun (port, {interfaces}) -> port, interfaces) ports in List.filter (fun (_, ifs) -> List.length ifs > 1) names else - match !kind with + match !backend_kind with | Openvswitch -> List.concat (List.map Ovs.bridge_to_ports (Ovs.list_bridges ())) | Bridge -> raise Not_implemented ) () let get_vlan _ dbg ~name = Debug.with_thread_associated dbg (fun () -> - match !kind with + match !backend_kind with | Openvswitch -> Ovs.bridge_to_vlan name | Bridge -> raise Not_implemented ) () let add_default_flows _ dbg bridge mac interfaces = Debug.with_thread_associated dbg (fun () -> - match !kind with + match !backend_kind with | Openvswitch -> Ovs.add_default_flows bridge mac interfaces | Bridge -> () ) () @@ -611,7 +618,7 @@ module Bridge = struct debug "Adding port %s to bridge %s with interfaces %s%s" name bridge (String.concat ", " interfaces) (match bond_mac with Some mac -> " and MAC " ^ mac | None -> ""); - match !kind with + match !backend_kind with | Openvswitch -> if List.length interfaces = 1 then begin List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces; @@ -668,7 +675,7 @@ module Bridge = struct let ports = List.remove_assoc name config.ports in update_config bridge {config with ports} end; - match !kind with + match !backend_kind with | Openvswitch -> ignore (Ovs.destroy_port name) | Bridge -> @@ -677,7 +684,7 @@ module Bridge = struct let get_interfaces _ dbg ~name = Debug.with_thread_associated dbg (fun () -> - match !kind with + match !backend_kind with | Openvswitch -> Ovs.bridge_to_interfaces name | Bridge -> @@ -686,7 +693,7 @@ module Bridge = struct let get_fail_mode _ dbg ~name = Debug.with_thread_associated dbg (fun () -> - match !kind with + match !backend_kind with | Openvswitch -> begin match Ovs.get_fail_mode name with | "standalone" -> Some Standalone @@ -769,7 +776,7 @@ let on_startup () = (* the following is best-effort *) read_config (); remove_centos_config (); - if !Bridge.kind = Openvswitch then + if !backend_kind = Openvswitch then Ovs.set_max_idle 5000; Bridge.make_config () dbg ~conservative:true ~config:!config.bridge_config (); Interface.make_config () dbg ~conservative:true ~config:!config.interface_config (); From c5ebbb8a27ea78926c3f0386d7b069e523a8ee92 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 23 Sep 2014 10:56:25 +0100 Subject: [PATCH 051/260] CA-115557: networkd: implement enic workaround When the enic workaround needs to be applied (according to the check implemented in the previous commit), then when asked to add an interface to a bridge, create a VLAN0 device for the given interface, and add that to the bridge instead. This applies to bonded interfaces as well as individual ones (we simply add the VLAN0 device on top of the bond device). Also, in Interface.make_config, we need to take care to configure both the base device as well as the VLAN0 device with the same parameters. Finally, when destroying a bridge with a VLAN0 bond, we need to destroy the bond device as well. Signed-off-by: Rob Hoes --- networkd/network_server.ml | 39 ++++++++++++++++++++++++++++++-------- 1 file changed, 31 insertions(+), 8 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index fc400f8d0..bb7f13989 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -364,6 +364,17 @@ module Interface = struct end else config in + let config = + if need_enic_workaround () then + List.fold_left (fun accu (name, interface) -> + if (Sysfs.is_physical name && Linux_bonding.get_bond_master_of name = None) || Linux_bonding.is_bond_device name then + (name, interface) :: (Ip.vlan_name name 0, interface) :: accu + else + (name, interface) :: accu + ) [] config + else + config + in debug "** Configuring the following interfaces: %s" (String.concat ", " (List.map (fun (name, _) -> name) config)); let exec f = if conservative then (try f () with _ -> ()) else f () in List.iter (function (name, ({ipv4_conf; ipv4_gateway; ipv6_conf; ipv6_gateway; ipv4_routes; dns=nameservers,domains; mtu; @@ -539,8 +550,14 @@ module Bridge = struct Interface.bring_down () dbg ~name:dev; if Linux_bonding.is_bond_device dev then Linux_bonding.remove_bond_master dev; - if String.startswith "eth" dev && String.contains dev '.' then - ignore (Ip.destroy_vlan dev) + if (String.startswith "eth" dev || String.startswith "bond" dev) && String.contains dev '.' then begin + ignore (Ip.destroy_vlan dev); + let n = String.length dev in + if String.sub dev (n - 2) 2 = ".0" && need_enic_workaround () then + let vlan_base = String.sub dev 0 (n - 2) in + if Linux_bonding.is_bond_device vlan_base then + Linux_bonding.remove_bond_master (String.sub dev 0 (n - 2)) + end; ) ifs; Interface.set_ipv4_conf () dbg ~name ~conf:None4; ignore (Brctl.destroy_bridge name) @@ -643,10 +660,9 @@ module Bridge = struct name bridge end | Bridge -> - if List.length interfaces = 1 then begin - List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces; - ignore (Brctl.create_port bridge name) - end else begin + if List.length interfaces = 1 then + List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces + else begin if not (List.mem name (Sysfs.bridge_to_interfaces bridge)) then begin Linux_bonding.add_bond_master name; let bond_properties = @@ -662,9 +678,16 @@ module Bridge = struct | None -> warn "No MAC address specified for the bond" end end; - Interface.bring_up () dbg ~name; + Interface.bring_up () dbg ~name + end; + if need_enic_workaround () then begin + debug "Applying enic workaround: adding VLAN0 device to bridge"; + Ip.create_vlan name 0; + let vlan0 = Ip.vlan_name name 0 in + Interface.bring_up () dbg ~name:vlan0; + ignore (Brctl.create_port bridge vlan0) + end else ignore (Brctl.create_port bridge name) - end ) () let remove_port _ dbg ~bridge ~name = From 43d2a6a55d9fadbef50cc2a84244f62a843005d8 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sat, 27 Sep 2014 14:54:12 +0000 Subject: [PATCH 052/260] Use new cmdliner-based interface Note this changes the syntax slightly: instead of '-daemon' we should now use '--daemon'. Signed-off-by: David Scott --- Makefile | 6 +++++- networkd/networkd.ml | 16 +++++++++++++++- 2 files changed, 20 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index 819ea638e..bae8e3cad 100644 --- a/Makefile +++ b/Makefile @@ -15,9 +15,12 @@ setup.bin: setup.ml setup.data: setup.bin @./setup.bin -configure --enable-tests -build: setup.data setup.bin +build: setup.data setup.bin networkd/version.ml @./setup.bin -build -j $(J) +networkd/version.ml: VERSION + echo "let version = \"$(shell cat VERSION)\"" > networkd/version.ml + doc: setup.data setup.bin @./setup.bin -doc -j $(J) @@ -35,3 +38,4 @@ uninstall: clean: @ocamlbuild -clean @rm -f setup.data setup.log setup.bin + rm networkd/version.ml diff --git a/networkd/networkd.ml b/networkd/networkd.ml index a84680bb3..801d28279 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -60,8 +60,22 @@ let handle_shutdown () = Sys.set_signal Sys.sigint (Sys.Signal_handle stop); Sys.set_signal Sys.sigpipe Sys.Signal_ignore +let doc = String.concat "\n" [ + "This is the xapi toolstack network management daemon."; + ""; + "This service looks after host network configuration, including setting up bridges and/or openvswitch instances, configuring IP addresses etc."; +] + let _ = - Xcp_service.configure ~resources (); + begin match Xcp_service.configure2 + ~name:Sys.argv.(0) + ~version:Version.version + ~doc ~resources () with + | `Ok () -> () + | `Error m -> + Printf.fprintf stderr "%s\n" m; + exit 1 + end; let server = Xcp_service.make ~path:!Network_interface.default_path From 319114328b11991704f4243e6e583ca2bfb73e61 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sat, 27 Sep 2014 14:58:33 +0000 Subject: [PATCH 053/260] Create and install an xcp-networkd man page Signed-off-by: David Scott --- Makefile | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index bae8e3cad..964369dcd 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,7 @@ BINDIR ?= /usr/bin SBINDIR ?= /usr/sbin ETCDIR ?= /etc +MANDIR ?= /usr/share/man/man1 all: build doc .PHONY: test install uninstall clean @@ -17,6 +18,8 @@ setup.data: setup.bin build: setup.data setup.bin networkd/version.ml @./setup.bin -build -j $(J) + mv networkd.native xcp-networkd + ./xcp-networkd --help=groff > xcp-networkd.1 networkd/version.ml: VERSION echo "let version = \"$(shell cat VERSION)\"" > networkd/version.ml @@ -28,14 +31,20 @@ test: setup.bin build @./setup.bin -test install: - install -D networkd.native $(DESTDIR)$(SBINDIR)/xcp-networkd - install -D networkd_db.native $(DESTDIR)$(BINDIR)/networkd_db + mkdir -p $(DESTDIR)$(SBINDIR) + install xcp-networkd $(DESTDIR)$(SBINDIR)/xcp-networkd + mkdir -p $(DESTDIR)$(MANDIR) + install xcp-networkd.1 $(DESTDIR)$(MANDIR)/xcp-networkd.1 + mkdir -p $(DESTDIR)$(BINDIR) + install networkd_db.native $(DESTDIR)$(BINDIR)/networkd_db uninstall: rm -f $(DESTDIR)$(SBINDIR)/xcp-networkd + rm -f $(DESTDIR)$(MANDIR)/xcp-networkd.1 rm -f $(DESTDIR)$(SBINDIR)/networkd_db clean: @ocamlbuild -clean @rm -f setup.data setup.log setup.bin rm networkd/version.ml + rm xcp-networkd xcp-networkd.1 From da9c6ce1bc019dcc474cbb072773a168360599b6 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sat, 27 Sep 2014 14:58:45 +0000 Subject: [PATCH 054/260] Update .gitignore Signed-off-by: David Scott --- .gitignore | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index cb823d18a..9df49a1cc 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,9 @@ *.swp - +setup.bin +networkd/version.ml +xcp-networkd +xcp-networkd.1 +*.native +setup.data +setup.log dist/ From 90439eab612cfbef569d7fd038f542a93f3a931b Mon Sep 17 00:00:00 2001 From: David Scott Date: Sat, 27 Sep 2014 15:01:27 +0000 Subject: [PATCH 055/260] Bump version to 0.9.5, update ChangeLog Signed-off-by: David Scott --- ChangeLog | 9 +++++++++ VERSION | 2 +- _oasis | 2 +- 3 files changed, 11 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index 2731b252a..9be82b35f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +0.9.5 (27-Sep-2014): +* Add man page and standard command-line options +* Use libnl to read stats from interfaces +* CA-137227: Checking xen-backend in link of /sys/class/net/*/device/... +* Don't let naughty dhcp servers trick us into setting default routes +* Don't record RRDs for the "ovs-system" interface +* CA-137591: Removing all the interfaces before bringing the bridge down +* CA-140402: set max-idle to 5000ms on OVS + 0.9.4 (3-Jun-2014): * Use oasis for building * Update to new stdext interface diff --git a/VERSION b/VERSION index 965065db5..b0bb87854 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.9.3 +0.9.5 diff --git a/_oasis b/_oasis index 88958d14f..187aede84 100644 --- a/_oasis +++ b/_oasis @@ -1,6 +1,6 @@ OASISFormat: 0.3 Name: xcp-networkd -Version: 0.9.4 +Version: 0.9.5 Synopsis: XCP Network Daemon Authors: Rob Hoes License: LGPL-2.1 with OCaml linking exception From f4cf3eb1a7151f84f3b6421a03860b4e3a33f646 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 30 Sep 2014 11:21:57 +0100 Subject: [PATCH 056/260] CA-147516: networkd fix for VLANs plus enic-workaround When the "enic" workaround from c5ebbb8a2 is in effect, we need to make sure that VLAN names (for additional VLANs) are still constructed correctly, as usual. Signed-off-by: Rob Hoes --- networkd/network_server.ml | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index bb7f13989..bac3d20f2 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -503,9 +503,19 @@ module Bridge = struct ) current_interfaces; (* Now create the new VLAN device and add it to the bridge *) - let parent_interface = List.hd (List.filter (fun n -> + let parent_bridge_interface = List.hd (List.filter (fun n -> String.startswith "eth" n || String.startswith "bond" n ) (Sysfs.bridge_to_interfaces parent)) in + let parent_interface = + if need_enic_workaround () then begin + let n = String.length parent_bridge_interface in + let m = String.sub parent_bridge_interface 0 (n - 2) in + if vlan = 0 then + error "The enic workaround is in effect. Bridge %s is used for VLAN 0 on %s." parent m; + m + end else + parent_bridge_interface + in Ip.create_vlan parent_interface vlan; let vlan_name = Ip.vlan_name parent_interface vlan in Interface.bring_up () dbg ~name:vlan_name; From 0b9e2ed001af670705b71e992ad71068355d8110 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Wed, 1 Oct 2014 18:04:43 +0100 Subject: [PATCH 057/260] Initial version of a CLI for networkd Highly experimental! Signed-off-by: Rob Hoes --- _oasis | 5 + _tags | 21 ++- cli/network_cli.ml | 354 +++++++++++++++++++++++++++++++++++++++++++++ lib/META | 4 +- myocamlbuild.ml | 54 ++++--- setup.ml | 269 +++++++++++++++++++++++++--------- 6 files changed, 615 insertions(+), 92 deletions(-) create mode 100644 cli/network_cli.ml diff --git a/_oasis b/_oasis index 187aede84..3b0ee2f28 100644 --- a/_oasis +++ b/_oasis @@ -44,4 +44,9 @@ Test test_networkd Command: $network_test WorkingDirectory: . +Executable cli + CompiledObject: best + Path: cli + MainIs: network_cli.ml + BuildDepends: cmdliner, stdext, network-libs, xcp, xcp.network diff --git a/_tags b/_tags index 029f7bd59..9be7e9a7f 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 25ce055fb4cc4259cfd4fd1e986a20f1) +# DO NOT EDIT (digest: 69abe13a880191e9d4ddc9d091092ce0) # 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 @@ -87,5 +87,24 @@ : pkg_xcp-inventory : pkg_xcp.network : use_networklibs +# Executable cli +: pkg_cmdliner +: pkg_forkexec +: pkg_rpclib +: pkg_stdext +: pkg_threads +: pkg_xcp +: pkg_xcp-inventory +: pkg_xcp.network +: use_networklibs +: pkg_cmdliner +: pkg_forkexec +: pkg_rpclib +: pkg_stdext +: pkg_threads +: pkg_xcp +: pkg_xcp-inventory +: pkg_xcp.network +: use_networklibs # OASIS_STOP diff --git a/cli/network_cli.ml b/cli/network_cli.ml new file mode 100644 index 000000000..b7119b642 --- /dev/null +++ b/cli/network_cli.ml @@ -0,0 +1,354 @@ +open Network_interface +open Network_client +open Cmdliner +open Xstringext + +let dbg = "cli" + +let (|>) x f = f x + +(* Interface commands *) + +let iface_arg = + let doc = "Interface name" in + Arg.(required & pos 0 (some string) None & info [] ~docv:"INTERFACE" ~doc) + +let list_iface () = + let all = Client.Interface.get_all dbg () in + List.iter print_endline all + +let list_iface_cmd = + let doc = "List all interfaces" in + let man = [] in + Term.(pure list_iface $ pure ()), + Term.info "list-iface" ~doc ~man + +let get_mac iface = + try + let mac = Client.Interface.get_mac dbg iface in + `Ok (print_endline mac) + with _ -> + `Error (false, iface ^ " is not an interface") + +let get_mac_cmd = + let doc = "Get the MAC address of an interface" in + let man = [] in + Term.(ret (pure get_mac $ iface_arg)), + Term.info "get-mac" ~doc ~man + +let is_up iface = + try + let up = Client.Interface.is_up dbg iface in + `Ok (print_endline (if up then "up" else "not up")) + with _ -> + `Error (false, iface ^ " is not an interface") + +let is_up_cmd = + let doc = "Check whether an interface is up or down" in + let man = [] in + Term.(ret (pure is_up $ iface_arg)), + Term.info "is-up" ~doc ~man + +let get_ipv4_addr iface = + try + let addrs = Client.Interface.get_ipv4_addr dbg iface in + List.iter (fun (addr, prefix) -> + Printf.printf "%s/%d\n" (Unix.string_of_inet_addr addr) prefix + ) addrs; + `Ok () + with _ -> + `Error (false, iface ^ " is not an interface") + +let get_ipv4_addr_cmd = + let doc = "Get IPv4 addresses (CIDRs) of an interface" in + let man = [] in + Term.(ret (pure get_ipv4_addr $ iface_arg)), + Term.info "get-ipv4-addr" ~doc ~man + +let set_ipv4_addr iface conf = + try + let conf' = + if conf = "none" then + None4 + else if conf = "dhcp" then + DHCP4 + else + let i = String.index conf '/' in + let n = String.length conf in + let addr = Unix.inet_addr_of_string (String.sub conf 0 i) in + let prefix = String.sub conf (i + 1) (n - i - 1) |> int_of_string in + Static4 [addr, prefix] + in + Client.Interface.set_ipv4_conf dbg iface conf'; + `Ok () + with _ -> + `Error (false, "something went wrong") + +let set_ipv4_addr_cmd = + let doc = "Interface name (none|dhcp|)" in + let conf_arg = Arg.(required & pos 1 (some string) None & info [] ~docv:"IPV4-CONF" ~doc) in + let doc = "Set IPv4 configuration of an interface" in + let man = [] in + Term.(ret (pure set_ipv4_addr $ iface_arg $ conf_arg)), + Term.info "set-ipv4-addr" ~doc ~man + +let get_ipv4_gateway iface = + try + let addr = Client.Interface.get_ipv4_gateway dbg iface in + (match addr with + | Some addr -> Printf.printf "%s\n" (Unix.string_of_inet_addr addr) + | None -> () + ); + `Ok () + with _ -> + `Error (false, iface ^ " is not an interface") + +let get_ipv4_gateway_cmd = + let doc = "If there is an IPv4 default route through the interface, get the gateway address" in + let man = [] in + Term.(ret (pure get_ipv4_gateway $ iface_arg)), + Term.info "get-ipv4-gateway" ~doc ~man + +let set_ipv4_gateway iface addr = + try + let addr' = Unix.inet_addr_of_string addr in + Client.Interface.set_ipv4_gateway dbg iface addr'; + `Ok () + with _ -> + `Error (false, "something went wrong") + +let set_ipv4_gateway_cmd = + let doc = "Gateway IPv4 address" in + let addr_arg = Arg.(required & pos 1 (some string) None & info [] ~docv:"IPV4-GATEWAY" ~doc) in + let doc = "Set IPv4 gateway for an interface" in + let man = [] in + Term.(ret (pure set_ipv4_gateway $ iface_arg $ addr_arg)), + Term.info "set-ipv4-gateway" ~doc ~man + +let get_ipv6_addr iface = + try + let addrs = Client.Interface.get_ipv6_addr dbg iface in + List.iter (fun (addr, prefix) -> + Printf.printf "%s/%d\n" (Unix.string_of_inet_addr addr) prefix + ) addrs; + `Ok () + with _ -> + `Error (false, iface ^ " is not an interface") + +let get_ipv6_addr_cmd = + let doc = "Get IPv6 addresses (CIDRs) of an interface" in + let man = [] in + Term.(ret (pure get_ipv6_addr $ iface_arg)), + Term.info "get-ipv6-addr" ~doc ~man + +let set_ipv6_addr iface conf = + try + let conf' = + if conf = "none" then + None6 + else if conf = "linklocal" then + Linklocal6 + else if conf = "dhcp" then + DHCP6 + else if conf = "autoconf" then + Autoconf6 + else + let i = String.index conf '/' in + let n = String.length conf in + let addr = Unix.inet_addr_of_string (String.sub conf 0 i) in + let prefix = String.sub conf (i + 1) (n - i - 1) |> int_of_string in + Static6 [addr, prefix] + in + Client.Interface.set_ipv6_conf dbg iface conf'; + `Ok () + with _ -> + `Error (false, "something went wrong") + +let set_ipv6_addr_cmd = + let doc = "Interface name (none|linklocal|dhcp|autoconf|)" in + let conf_arg = Arg.(required & pos 1 (some string) None & info [] ~docv:"IPV6-CONF" ~doc) in + let doc = "Set IPv6 configuration of an interface" in + let man = [] in + Term.(ret (pure set_ipv6_addr $ iface_arg $ conf_arg)), + Term.info "set-ipv6-addr" ~doc ~man + +let get_ipv6_gateway iface = + try + let addr = Client.Interface.get_ipv6_gateway dbg iface in + (match addr with + | Some addr -> Printf.printf "%s\n" (Unix.string_of_inet_addr addr) + | None -> () + ); + `Ok () + with _ -> + `Error (false, iface ^ " is not an interface") + +let get_ipv6_gateway_cmd = + let doc = "If there is an IPv6 default route through the interface, get the gateway address" in + let man = [] in + Term.(ret (pure get_ipv6_gateway $ iface_arg)), + Term.info "get-ipv6-gateway" ~doc ~man + +let set_ipv6_gateway iface addr = + try + let addr' = Unix.inet_addr_of_string addr in + Client.Interface.set_ipv6_gateway dbg iface addr'; + `Ok () + with _ -> + `Error (false, "something went wrong") + +let set_ipv6_gateway_cmd = + let doc = "Gateway IPv6 address" in + let addr_arg = Arg.(required & pos 1 (some string) None & info [] ~docv:"IPV6-GATEWAY" ~doc) in + let doc = "Set IPv6 gateway for an interface" in + let man = [] in + Term.(ret (pure set_ipv6_gateway $ iface_arg $ addr_arg)), + Term.info "set-ipv6-gateway" ~doc ~man + +let get_dns () = + let nameservers, domains = Client.Interface.get_dns dbg "" in + Printf.printf "nameservers: %s\n" (String.concat ", " (List.map Unix.string_of_inet_addr nameservers)); + Printf.printf "domains: %s\n" (String.concat ", " domains); + `Ok () + +let get_dns_cmd = + let doc = "Get DNS nameservers and domains" in + let man = [] in + Term.(ret (pure get_dns $ pure ())), + Term.info "get-dns" ~doc ~man + +let set_dns iface nameservers domains = + try + let ns = match nameservers with + | Some x -> List.map Unix.inet_addr_of_string (String.split ',' x) + | None -> [] + in + let d = match domains with + | Some x -> String.split ',' x + | None -> [] + in + Client.Interface.set_dns dbg iface ns d; + `Ok () + with _ -> + `Error (false, "something went wrong") + +let set_dns_cmd = + let doc = "Comma-separated list of nameservers" in + let nameservers_arg = Arg.(value & opt (some string) None & info ["nameservers"] ~docv:"NAMESERVERS" ~doc) in + let doc = "Comma-separated list of domains" in + let domains_arg = Arg.(value & opt (some string) None & info ["domains"] ~docv:"DOMAINS" ~doc) in + let doc = "Set DNS nameservers and domains" in + let man = [] in + Term.(ret (pure set_dns $ iface_arg $ nameservers_arg $ domains_arg)), + Term.info "set-dns" ~doc ~man + +let get_mtu iface = + try + let mtu = Client.Interface.get_mtu dbg iface in + Printf.printf "%d\n" mtu; + `Ok () + with _ -> + `Error (false, iface ^ " is not an interface") + +let get_mtu_cmd = + let doc = "Get MTU" in + let man = [] in + Term.(ret (pure get_mtu $ iface_arg)), + Term.info "get-mtu" ~doc ~man + +let set_mtu iface mtu = + try + Client.Interface.set_mtu dbg iface mtu; + `Ok () + with _ -> + `Error (false, iface ^ " is not an interface") + +let set_mtu_cmd = + let doc = "The MTU" in + let mtu_arg = Arg.(required & pos 1 (some int) None & info [] ~docv:"MTU" ~doc) in + let doc = "Get MTU" in + let man = [] in + Term.(ret (pure set_mtu $ iface_arg $ mtu_arg)), + Term.info "set-mtu" ~doc ~man + +let get_persistence iface = + try + let persistent = Client.Interface.is_persistent dbg iface in + Printf.printf "%s\n" (if persistent then "persistent" else "not persistent"); + `Ok () + with _ -> + `Error (false, iface ^ " is not an interface") + +let get_persistence_cmd = + let doc = "Get persistence" in + let man = [] in + Term.(ret (pure get_persistence $ iface_arg)), + Term.info "get-persistence" ~doc ~man + +let set_persistence iface persistence = + try + if persistence = "on" then + `Ok (Client.Interface.set_persistent dbg iface true) + else if persistence = "off" then + `Ok (Client.Interface.set_persistent dbg iface false) + else + `Error (false, "'on' or 'off' please") + with _ -> + `Error (false, iface ^ " is not an interface") + +let set_persistence_cmd = + let doc = "Persistence (on|off)" in + let persistence_arg = Arg.(required & pos 1 (some string) None & info [] ~docv:"PERSISTENCE" ~doc) in + let doc = "Set persistence" in + let man = [] in + Term.(ret (pure set_persistence $ iface_arg $ persistence_arg)), + Term.info "set-persistence" ~doc ~man + +(* Bridge commands *) + +let list_br () = + let all = Client.Bridge.get_all dbg () in + List.iter print_endline all + +let list_br_cmd = + let doc = "List all bridges" in + let man = [] in + Term.(pure list_br $ pure ()), + Term.info "list-br" ~doc ~man + +let read_config path = + let config_json = Unixext.string_of_file path in + config_json |> Jsonrpc.of_string |> config_t_of_rpc + +let config path = + let config = read_config path in + Client.Bridge.make_config dbg ~config:config.bridge_config (); + Client.Interface.make_config dbg ~config:config.interface_config (); + `Ok () + +let config_cmd = + let doc = "Path to JSON config file" in + let config_arg = Arg.(required & pos 0 (some file) None & info [] ~docv:"CONFIG-FILE" ~doc) in + let doc = "Set network configuration based on a config file" in + let man = [] in + Term.(ret (pure config $ config_arg)), + Term.info "config" ~doc ~man + +let default_cmd = + let doc = "CLI for xcp-networkd" in + let man = [] in + Term.(ret (pure (`Help (`Pager, None)))), + Term.info "network-cli" ~version:"0.1" ~doc ~man + +let cmds = [ + list_iface_cmd; get_mac_cmd; is_up_cmd; + get_ipv4_addr_cmd; set_ipv4_addr_cmd; get_ipv4_gateway_cmd; set_ipv4_gateway_cmd; + get_ipv6_addr_cmd; set_ipv6_addr_cmd; get_ipv6_gateway_cmd; set_ipv6_gateway_cmd; + get_dns_cmd; set_dns_cmd; get_mtu_cmd; set_mtu_cmd; + get_persistence_cmd; set_persistence_cmd; + list_br_cmd; + config_cmd] + +let _ = + match Term.eval_choice default_cmd cmds with + | `Error _ -> exit 1 | _ -> exit 0 diff --git a/lib/META b/lib/META index c6a36cffc..900fb6d75 100644 --- a/lib/META +++ b/lib/META @@ -1,6 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: 91b748c7a2332c0932eed83315151278) -version = "0.9.4" +# DO NOT EDIT (digest: 1c79811cc8dd9ea01a505ead32a71432) +version = "0.9.5" description = "XCP Network Daemon" requires = "forkexec stdext threads rpclib stdext xcp-inventory xcp.network" archive(byte) = "networklibs.cma" diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 9ba62daf2..502d9a05d 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: b61c6662b23d9ed3268fd3f519fdb137) *) +(* DO NOT EDIT (digest: 2f48de2146b614fb40f18d31701b8707) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) @@ -259,6 +259,31 @@ module MyOCamlbuildFindlib = struct Ocamlbuild_pack.Lexers.blank_sep_strings + let exec_from_conf exec = + let exec = + let env_filename = Pathname.basename BaseEnvLight.default_filename in + let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in + try + BaseEnvLight.var_get exec env + with Not_found -> + Printf.eprintf "W: Cannot get variable %s\n" exec; + exec + in + let fix_win32 str = + if Sys.os_type = "Win32" then begin + let buff = Buffer.create (String.length str) in + (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. + *) + String.iter + (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) + str; + Buffer.contents buff + end else begin + str + end + in + fix_win32 exec + let split s ch = let buf = Buffer.create 13 in let x = ref [] in @@ -286,17 +311,7 @@ module MyOCamlbuildFindlib = struct with Not_found -> s (* ocamlfind command *) - let ocamlfind x = - let ocamlfind_prog = - let env_filename = Pathname.basename BaseEnvLight.default_filename in - let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in - try - BaseEnvLight.var_get "ocamlfind" env - with Not_found -> - Printf.eprintf "W: Cannot get variable ocamlfind"; - "ocamlfind" - in - S[Sh ocamlfind_prog; x] + let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] (* This lists all supported packages. *) let find_packages () = @@ -325,7 +340,7 @@ module MyOCamlbuildFindlib = struct let dispatch = function - | Before_options -> + | After_options -> (* By using Before_options one let command line options have an higher * priority on the contrary using After_options will guarantee to have * the higher priority override default commands by ocamlfind ones *) @@ -476,7 +491,7 @@ module MyOCamlbuildBase = struct try opt := no_trailing_dot (BaseEnvLight.var_get var env) with Not_found -> - Printf.eprintf "W: Cannot get variable %s" var) + Printf.eprintf "W: Cannot get variable %s\n" var) [ Options.ext_obj, "ext_obj"; Options.ext_lib, "ext_lib"; @@ -576,7 +591,7 @@ module MyOCamlbuildBase = struct end -# 579 "myocamlbuild.ml" +# 594 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { @@ -599,12 +614,17 @@ let package_default = ]) ]; includes = - [("test", ["lib"]); ("networkd_db", ["lib"]); ("networkd", ["lib"])] + [ + ("test", ["lib"]); + ("networkd_db", ["lib"]); + ("networkd", ["lib"]); + ("cli", ["lib"]) + ] } ;; let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; -# 609 "myocamlbuild.ml" +# 629 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/setup.ml b/setup.ml index b66076247..0e525c3d2 100644 --- a/setup.ml +++ b/setup.ml @@ -1,9 +1,9 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 4af85109009a4a9acf4da8dcb4c88f5b) *) +(* DO NOT EDIT (digest: 0f4e8b4525108e6ff1e0995a261d587a) *) (* - Regenerated by OASIS v0.4.2 + Regenerated by OASIS v0.4.4 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) @@ -258,29 +258,62 @@ module OASISUtils = struct open OASISGettext - module MapString = Map.Make(String) + module MapExt = + struct + module type S = + sig + include Map.S + val add_list: 'a t -> (key * 'a) list -> 'a t + val of_list: (key * 'a) list -> 'a t + val to_list: 'a t -> (key * 'a) list + end + + module Make (Ord: Map.OrderedType) = + struct + include Map.Make(Ord) + + let rec add_list t = + function + | (k, v) :: tl -> add_list (add k v t) tl + | [] -> t + let of_list lst = add_list empty lst - let map_string_of_assoc assoc = - List.fold_left - (fun acc (k, v) -> MapString.add k v acc) - MapString.empty - assoc + let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] + end + end - module SetString = Set.Make(String) + module MapString = MapExt.Make(String) - let set_string_add_list st lst = - List.fold_left - (fun acc e -> SetString.add e acc) - st - lst + module SetExt = + struct + module type S = + sig + include Set.S + val add_list: t -> elt list -> t + val of_list: elt list -> t + val to_list: t -> elt list + end + + module Make (Ord: Set.OrderedType) = + struct + include Set.Make(Ord) + + let rec add_list t = + function + | e :: tl -> add_list (add e t) tl + | [] -> t + + let of_list lst = add_list empty lst + + let to_list = elements + end + end - let set_string_of_list = - set_string_add_list - SetString.empty + module SetString = SetExt.Make(String) let compare_csl s1 s2 = @@ -300,7 +333,7 @@ module OASISUtils = struct end) module SetStringCsl = - Set.Make + SetExt.Make (struct type t = string let compare = compare_csl @@ -1047,6 +1080,21 @@ module OASISExpr = struct end +module OASISText = struct +(* # 22 "src/oasis/OASISText.ml" *) + + + + type elt = + | Para of string + | Verbatim of string + | BlankLine + + + type t = elt list + +end + module OASISTypes = struct (* # 22 "src/oasis/OASISTypes.ml" *) @@ -1279,41 +1327,42 @@ module OASISTypes = struct type package = { - oasis_version: OASISVersion.t; - ocaml_version: OASISVersion.comparator option; - findlib_version: OASISVersion.comparator option; - alpha_features: string list; - beta_features: string list; - name: package_name; - version: OASISVersion.t; - license: OASISLicense.t; - license_file: unix_filename option; - copyrights: string list; - maintainers: string list; - authors: string list; - homepage: url option; - synopsis: string; - description: string option; - categories: url list; - - conf_type: [`Configure] plugin; - conf_custom: custom; - - build_type: [`Build] plugin; - build_custom: custom; - - install_type: [`Install] plugin; - install_custom: custom; - uninstall_custom: custom; - - clean_custom: custom; - distclean_custom: custom; - - files_ab: unix_filename list; - sections: section list; - plugins: [`Extra] plugin list; - schema_data: PropList.Data.t; - plugin_data: plugin_data; + oasis_version: OASISVersion.t; + ocaml_version: OASISVersion.comparator option; + findlib_version: OASISVersion.comparator option; + alpha_features: string list; + beta_features: string list; + name: package_name; + version: OASISVersion.t; + license: OASISLicense.t; + license_file: unix_filename option; + copyrights: string list; + maintainers: string list; + authors: string list; + homepage: url option; + synopsis: string; + description: OASISText.t option; + categories: url list; + + conf_type: [`Configure] plugin; + conf_custom: custom; + + build_type: [`Build] plugin; + build_custom: custom; + + install_type: [`Install] plugin; + install_custom: custom; + uninstall_custom: custom; + + clean_custom: custom; + distclean_custom: custom; + + files_ab: unix_filename list; + sections: section list; + plugins: [`Extra] plugin list; + disable_oasis_section: unix_filename list; + schema_data: PropList.Data.t; + plugin_data: plugin_data; } @@ -1367,6 +1416,24 @@ module OASISFeatures = struct let plugin_version plugin_kind plugin_name t = MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions + + let to_string t = + Printf.sprintf + "oasis_version: %s; alpha_features: %s; beta_features: %s; \ + plugins_version: %s" + (OASISVersion.string_of_version t.oasis_version) + (String.concat ", " t.alpha_features) + (String.concat ", " t.beta_features) + (String.concat ", " + (MapPlugin.fold + (fun (_, plg) ver_opt acc -> + (plg^ + (match ver_opt with + | Some v -> + " "^(OASISVersion.string_of_version v) + | None -> "")) + :: acc) + t.plugin_versions [])) end type origin = @@ -1407,6 +1474,17 @@ module OASISFeatures = struct let beta = InDev Beta + let to_string t = + Printf.sprintf + "feature: %s; plugin: %s; publication: %s" + t.name + (match t.plugin with + | None -> "" + | Some (_, nm, _) -> nm) + (match t.publication with + | InDev stage -> string_of_stage stage + | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) + let data_check t data origin = let no_message = "no message" in @@ -1639,6 +1717,18 @@ module OASISFeatures = struct create "dynrun_for_release" alpha (fun () -> s_ "Make '-setup-update dynamic' suitable for releasing project.") + + + let compiled_setup_ml = + create "compiled_setup_ml" alpha + (fun () -> + s_ "It compiles the setup.ml and speed-up actions done with it.") + + let disable_oasis_section = + create "disable_oasis_section" alpha + (fun () -> + s_ "Allows the OASIS section comments and digest to be omitted in \ + generated files.") end module OASISUnixPath = struct @@ -2727,14 +2817,17 @@ module OASISFileUtil = struct let rmdir ~ctxt tgt = - if Sys.readdir tgt = [||] then - begin - match Sys.os_type with - | "Win32" -> - OASISExec.run ~ctxt "rd" [q tgt] - | _ -> - OASISExec.run ~ctxt "rm" ["-r"; q tgt] - end + if Sys.readdir tgt = [||] then begin + match Sys.os_type with + | "Win32" -> + OASISExec.run ~ctxt "rd" [q tgt] + | _ -> + OASISExec.run ~ctxt "rm" ["-r"; q tgt] + end else begin + OASISMessage.error ~ctxt + (f_ "Cannot remove directory '%s': not empty.") + tgt + end let glob ~ctxt fn = @@ -2782,7 +2875,7 @@ module OASISFileUtil = struct end -# 2785 "setup.ml" +# 2878 "setup.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) @@ -2887,7 +2980,7 @@ module BaseEnvLight = struct end -# 2890 "setup.ml" +# 2983 "setup.ml" module BaseContext = struct (* # 22 "src/base/BaseContext.ml" *) @@ -5298,7 +5391,7 @@ module BaseSetup = struct end -# 5301 "setup.ml" +# 5394 "setup.ml" module InternalConfigurePlugin = struct (* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) @@ -6147,7 +6240,7 @@ module InternalInstallPlugin = struct end -# 6150 "setup.ml" +# 6243 "setup.ml" module OCamlbuildCommon = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) @@ -6520,7 +6613,7 @@ module OCamlbuildDocPlugin = struct end -# 6523 "setup.ml" +# 6616 "setup.ml" module CustomPlugin = struct (* # 22 "src/plugins/custom/CustomPlugin.ml" *) @@ -6668,7 +6761,7 @@ module CustomPlugin = struct end -# 6671 "setup.ml" +# 6764 "setup.ml" open OASISTypes;; let setup_t = @@ -6723,7 +6816,7 @@ let setup_t = alpha_features = []; beta_features = []; name = "xcp-networkd"; - version = "0.9.4"; + version = "0.9.5"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit @@ -6938,15 +7031,47 @@ let setup_t = true) ]; test_tools = [ExternalTool "ocamlbuild"] - }) + }); + Executable + ({ + cs_name = "cli"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "cli"; + bs_compiled_object = Best; + bs_build_depends = + [ + FindlibPackage ("cmdliner", None); + FindlibPackage ("stdext", None); + InternalLibrary "networklibs"; + FindlibPackage ("xcp", None); + FindlibPackage ("xcp.network", 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 = false; exec_main_is = "network_cli.ml"}) ]; plugins = [(`Extra, "META", Some "0.2")]; + disable_oasis_section = []; schema_data = PropList.Data.create (); plugin_data = [] }; oasis_fn = Some "_oasis"; - oasis_version = "0.4.2"; - oasis_digest = Some "\r\232-\232\227fs7j\240\016\152\179\188\188\""; + oasis_version = "0.4.4"; + oasis_digest = + Some "\127\155O\248\207\197\249R\171\219\154\237\180\196\002\164"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -6954,6 +7079,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 6958 "setup.ml" +# 7083 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 01e6a9f683f726ce12b3f62633895225b9473ac2 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Fri, 3 Oct 2014 18:14:09 +0100 Subject: [PATCH 058/260] Fix up trunk Signed-off-by: Jon Ludlam --- Makefile | 16 ---- lib/META | 4 +- myocamlbuild.ml | 47 ++++------ setup.ml | 236 +++++++++++++++--------------------------------- 4 files changed, 89 insertions(+), 214 deletions(-) diff --git a/Makefile b/Makefile index e5add6d47..964369dcd 100644 --- a/Makefile +++ b/Makefile @@ -1,10 +1,7 @@ BINDIR ?= /usr/bin SBINDIR ?= /usr/sbin ETCDIR ?= /etc -<<<<<<< HEAD -======= MANDIR ?= /usr/share/man/man1 ->>>>>>> dea415eb2a75f8642c951151ae3f8ba6786f1cf9 all: build doc .PHONY: test install uninstall clean @@ -19,10 +16,6 @@ setup.bin: setup.ml setup.data: setup.bin @./setup.bin -configure --enable-tests -<<<<<<< HEAD -build: setup.data setup.bin - @./setup.bin -build -j $(J) -======= build: setup.data setup.bin networkd/version.ml @./setup.bin -build -j $(J) mv networkd.native xcp-networkd @@ -30,7 +23,6 @@ build: setup.data setup.bin networkd/version.ml networkd/version.ml: VERSION echo "let version = \"$(shell cat VERSION)\"" > networkd/version.ml ->>>>>>> dea415eb2a75f8642c951151ae3f8ba6786f1cf9 doc: setup.data setup.bin @./setup.bin -doc -j $(J) @@ -39,17 +31,12 @@ test: setup.bin build @./setup.bin -test install: -<<<<<<< HEAD - install -D networkd.native $(DESTDIR)$(SBINDIR)/xcp-networkd - install -D networkd_db.native $(DESTDIR)$(BINDIR)/networkd_db -======= mkdir -p $(DESTDIR)$(SBINDIR) install xcp-networkd $(DESTDIR)$(SBINDIR)/xcp-networkd mkdir -p $(DESTDIR)$(MANDIR) install xcp-networkd.1 $(DESTDIR)$(MANDIR)/xcp-networkd.1 mkdir -p $(DESTDIR)$(BINDIR) install networkd_db.native $(DESTDIR)$(BINDIR)/networkd_db ->>>>>>> dea415eb2a75f8642c951151ae3f8ba6786f1cf9 uninstall: rm -f $(DESTDIR)$(SBINDIR)/xcp-networkd @@ -59,8 +46,5 @@ uninstall: clean: @ocamlbuild -clean @rm -f setup.data setup.log setup.bin -<<<<<<< HEAD -======= rm networkd/version.ml rm xcp-networkd xcp-networkd.1 ->>>>>>> dea415eb2a75f8642c951151ae3f8ba6786f1cf9 diff --git a/lib/META b/lib/META index 900fb6d75..c6a36cffc 100644 --- a/lib/META +++ b/lib/META @@ -1,6 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: 1c79811cc8dd9ea01a505ead32a71432) -version = "0.9.5" +# DO NOT EDIT (digest: 91b748c7a2332c0932eed83315151278) +version = "0.9.4" description = "XCP Network Daemon" requires = "forkexec stdext threads rpclib stdext xcp-inventory xcp.network" archive(byte) = "networklibs.cma" diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 8ec5d77b9..9ba62daf2 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 1b562e89c2fc3873269cda485f3abe87) *) +(* DO NOT EDIT (digest: b61c6662b23d9ed3268fd3f519fdb137) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) @@ -259,31 +259,6 @@ module MyOCamlbuildFindlib = struct Ocamlbuild_pack.Lexers.blank_sep_strings - let exec_from_conf exec = - let exec = - let env_filename = Pathname.basename BaseEnvLight.default_filename in - let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in - try - BaseEnvLight.var_get exec env - with Not_found -> - Printf.eprintf "W: Cannot get variable %s\n" exec; - exec - in - let fix_win32 str = - if Sys.os_type = "Win32" then begin - let buff = Buffer.create (String.length str) in - (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. - *) - String.iter - (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) - str; - Buffer.contents buff - end else begin - str - end - in - fix_win32 exec - let split s ch = let buf = Buffer.create 13 in let x = ref [] in @@ -311,7 +286,17 @@ module MyOCamlbuildFindlib = struct with Not_found -> s (* ocamlfind command *) - let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] + let ocamlfind x = + let ocamlfind_prog = + let env_filename = Pathname.basename BaseEnvLight.default_filename in + let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in + try + BaseEnvLight.var_get "ocamlfind" env + with Not_found -> + Printf.eprintf "W: Cannot get variable ocamlfind"; + "ocamlfind" + in + S[Sh ocamlfind_prog; x] (* This lists all supported packages. *) let find_packages () = @@ -340,7 +325,7 @@ module MyOCamlbuildFindlib = struct let dispatch = function - | After_options -> + | Before_options -> (* By using Before_options one let command line options have an higher * priority on the contrary using After_options will guarantee to have * the higher priority override default commands by ocamlfind ones *) @@ -491,7 +476,7 @@ module MyOCamlbuildBase = struct try opt := no_trailing_dot (BaseEnvLight.var_get var env) with Not_found -> - Printf.eprintf "W: Cannot get variable %s\n" var) + Printf.eprintf "W: Cannot get variable %s" var) [ Options.ext_obj, "ext_obj"; Options.ext_lib, "ext_lib"; @@ -591,7 +576,7 @@ module MyOCamlbuildBase = struct end -# 594 "myocamlbuild.ml" +# 579 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { @@ -620,6 +605,6 @@ let package_default = let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; -# 624 "myocamlbuild.ml" +# 609 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/setup.ml b/setup.ml index ffa125432..b66076247 100644 --- a/setup.ml +++ b/setup.ml @@ -1,9 +1,9 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: e9b55010b1be95bd302ac838f5f0d979) *) +(* DO NOT EDIT (digest: 4af85109009a4a9acf4da8dcb4c88f5b) *) (* - Regenerated by OASIS v0.4.4 + Regenerated by OASIS v0.4.2 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) @@ -258,62 +258,29 @@ module OASISUtils = struct open OASISGettext - module MapExt = - struct - module type S = - sig - include Map.S - val add_list: 'a t -> (key * 'a) list -> 'a t - val of_list: (key * 'a) list -> 'a t - val to_list: 'a t -> (key * 'a) list - end - - module Make (Ord: Map.OrderedType) = - struct - include Map.Make(Ord) - - let rec add_list t = - function - | (k, v) :: tl -> add_list (add k v t) tl - | [] -> t - - let of_list lst = add_list empty lst - - let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] - end - end + module MapString = Map.Make(String) - module MapString = MapExt.Make(String) + let map_string_of_assoc assoc = + List.fold_left + (fun acc (k, v) -> MapString.add k v acc) + MapString.empty + assoc - module SetExt = - struct - module type S = - sig - include Set.S - val add_list: t -> elt list -> t - val of_list: elt list -> t - val to_list: t -> elt list - end - - module Make (Ord: Set.OrderedType) = - struct - include Set.Make(Ord) - - let rec add_list t = - function - | e :: tl -> add_list (add e t) tl - | [] -> t + module SetString = Set.Make(String) - let of_list lst = add_list empty lst - let to_list = elements - end - end + let set_string_add_list st lst = + List.fold_left + (fun acc e -> SetString.add e acc) + st + lst - module SetString = SetExt.Make(String) + let set_string_of_list = + set_string_add_list + SetString.empty let compare_csl s1 s2 = @@ -333,7 +300,7 @@ module OASISUtils = struct end) module SetStringCsl = - SetExt.Make + Set.Make (struct type t = string let compare = compare_csl @@ -1080,21 +1047,6 @@ module OASISExpr = struct end -module OASISText = struct -(* # 22 "src/oasis/OASISText.ml" *) - - - - type elt = - | Para of string - | Verbatim of string - | BlankLine - - - type t = elt list - -end - module OASISTypes = struct (* # 22 "src/oasis/OASISTypes.ml" *) @@ -1327,42 +1279,41 @@ module OASISTypes = struct type package = { - oasis_version: OASISVersion.t; - ocaml_version: OASISVersion.comparator option; - findlib_version: OASISVersion.comparator option; - alpha_features: string list; - beta_features: string list; - name: package_name; - version: OASISVersion.t; - license: OASISLicense.t; - license_file: unix_filename option; - copyrights: string list; - maintainers: string list; - authors: string list; - homepage: url option; - synopsis: string; - description: OASISText.t option; - categories: url list; - - conf_type: [`Configure] plugin; - conf_custom: custom; - - build_type: [`Build] plugin; - build_custom: custom; - - install_type: [`Install] plugin; - install_custom: custom; - uninstall_custom: custom; - - clean_custom: custom; - distclean_custom: custom; - - files_ab: unix_filename list; - sections: section list; - plugins: [`Extra] plugin list; - disable_oasis_section: unix_filename list; - schema_data: PropList.Data.t; - plugin_data: plugin_data; + oasis_version: OASISVersion.t; + ocaml_version: OASISVersion.comparator option; + findlib_version: OASISVersion.comparator option; + alpha_features: string list; + beta_features: string list; + name: package_name; + version: OASISVersion.t; + license: OASISLicense.t; + license_file: unix_filename option; + copyrights: string list; + maintainers: string list; + authors: string list; + homepage: url option; + synopsis: string; + description: string option; + categories: url list; + + conf_type: [`Configure] plugin; + conf_custom: custom; + + build_type: [`Build] plugin; + build_custom: custom; + + install_type: [`Install] plugin; + install_custom: custom; + uninstall_custom: custom; + + clean_custom: custom; + distclean_custom: custom; + + files_ab: unix_filename list; + sections: section list; + plugins: [`Extra] plugin list; + schema_data: PropList.Data.t; + plugin_data: plugin_data; } @@ -1416,24 +1367,6 @@ module OASISFeatures = struct let plugin_version plugin_kind plugin_name t = MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions - - let to_string t = - Printf.sprintf - "oasis_version: %s; alpha_features: %s; beta_features: %s; \ - plugins_version: %s" - (OASISVersion.string_of_version t.oasis_version) - (String.concat ", " t.alpha_features) - (String.concat ", " t.beta_features) - (String.concat ", " - (MapPlugin.fold - (fun (_, plg) ver_opt acc -> - (plg^ - (match ver_opt with - | Some v -> - " "^(OASISVersion.string_of_version v) - | None -> "")) - :: acc) - t.plugin_versions [])) end type origin = @@ -1474,17 +1407,6 @@ module OASISFeatures = struct let beta = InDev Beta - let to_string t = - Printf.sprintf - "feature: %s; plugin: %s; publication: %s" - t.name - (match t.plugin with - | None -> "" - | Some (_, nm, _) -> nm) - (match t.publication with - | InDev stage -> string_of_stage stage - | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) - let data_check t data origin = let no_message = "no message" in @@ -1717,18 +1639,6 @@ module OASISFeatures = struct create "dynrun_for_release" alpha (fun () -> s_ "Make '-setup-update dynamic' suitable for releasing project.") - - - let compiled_setup_ml = - create "compiled_setup_ml" alpha - (fun () -> - s_ "It compiles the setup.ml and speed-up actions done with it.") - - let disable_oasis_section = - create "disable_oasis_section" alpha - (fun () -> - s_ "Allows the OASIS section comments and digest to be omitted in \ - generated files.") end module OASISUnixPath = struct @@ -2817,17 +2727,14 @@ module OASISFileUtil = struct let rmdir ~ctxt tgt = - if Sys.readdir tgt = [||] then begin - match Sys.os_type with - | "Win32" -> - OASISExec.run ~ctxt "rd" [q tgt] - | _ -> - OASISExec.run ~ctxt "rm" ["-r"; q tgt] - end else begin - OASISMessage.error ~ctxt - (f_ "Cannot remove directory '%s': not empty.") - tgt - end + if Sys.readdir tgt = [||] then + begin + match Sys.os_type with + | "Win32" -> + OASISExec.run ~ctxt "rd" [q tgt] + | _ -> + OASISExec.run ~ctxt "rm" ["-r"; q tgt] + end let glob ~ctxt fn = @@ -2875,7 +2782,7 @@ module OASISFileUtil = struct end -# 2878 "setup.ml" +# 2785 "setup.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) @@ -2980,7 +2887,7 @@ module BaseEnvLight = struct end -# 2983 "setup.ml" +# 2890 "setup.ml" module BaseContext = struct (* # 22 "src/base/BaseContext.ml" *) @@ -5391,7 +5298,7 @@ module BaseSetup = struct end -# 5394 "setup.ml" +# 5301 "setup.ml" module InternalConfigurePlugin = struct (* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) @@ -6240,7 +6147,7 @@ module InternalInstallPlugin = struct end -# 6243 "setup.ml" +# 6150 "setup.ml" module OCamlbuildCommon = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) @@ -6613,7 +6520,7 @@ module OCamlbuildDocPlugin = struct end -# 6616 "setup.ml" +# 6523 "setup.ml" module CustomPlugin = struct (* # 22 "src/plugins/custom/CustomPlugin.ml" *) @@ -6761,7 +6668,7 @@ module CustomPlugin = struct end -# 6764 "setup.ml" +# 6671 "setup.ml" open OASISTypes;; let setup_t = @@ -6816,7 +6723,7 @@ let setup_t = alpha_features = []; beta_features = []; name = "xcp-networkd"; - version = "0.9.5"; + version = "0.9.4"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit @@ -7034,13 +6941,12 @@ let setup_t = }) ]; plugins = [(`Extra, "META", Some "0.2")]; - disable_oasis_section = []; schema_data = PropList.Data.create (); plugin_data = [] }; oasis_fn = Some "_oasis"; - oasis_version = "0.4.4"; - oasis_digest = Some "\r\246\248\019\214k`k\196\200'\245\154w\176\178"; + oasis_version = "0.4.2"; + oasis_digest = Some "\r\232-\232\227fs7j\240\016\152\179\188\188\""; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7048,6 +6954,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7052 "setup.ml" +# 6958 "setup.ml" (* OASIS_STOP *) let () = setup ();; From a1de2e111bfa3d0ddb9227a93e9f97da4b89d108 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 21 Oct 2014 15:21:32 +0100 Subject: [PATCH 059/260] CA-127274: Linux bridge: set forwarding delay to 0 after creating a bridge The forwarding delay is 30s by default, which means that for the first 30s after bringing up a bridge port, the port will be in "learning mode", and won't forward any packets. We want bridge ports to immediately go in "forwarding mode" instead. We did this in the past, but it was lost in the transition to xcp-networkd. Signed-off-by: Rob Hoes --- lib/network_utils.ml | 2 ++ networkd/network_server.ml | 1 + 2 files changed, 3 insertions(+) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 28f8b7f79..0b1d60ebb 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -921,6 +921,8 @@ module Brctl = struct if List.mem name (Sysfs.bridge_to_interfaces bridge) then ignore (call ~log:true ["delif"; bridge; name]) + let set_forwarding_delay bridge time = + ignore (call ~log:true ["setfd"; bridge; string_of_int time]) end module Ethtool = struct diff --git a/networkd/network_server.ml b/networkd/network_server.ml index bac3d20f2..d57f18cd4 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -487,6 +487,7 @@ module Bridge = struct vlan vlan_bug_workaround name) | Bridge -> ignore (Brctl.create_bridge name); + Brctl.set_forwarding_delay name 0; Opt.iter (Ip.set_mac name) mac; match vlan with | None -> () From 9d7f71bc67f326318cf4e35f5a7671819e48651f Mon Sep 17 00:00:00 2001 From: David Scott Date: Sun, 2 Nov 2014 18:56:59 +0000 Subject: [PATCH 060/260] Add opam file Signed-off-by: David Scott --- opam | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 opam diff --git a/opam b/opam new file mode 100644 index 000000000..2be0fa8be --- /dev/null +++ b/opam @@ -0,0 +1,15 @@ +opam-version: "1" +maintainer: "jonathan.ludlam@eu.citrix.com" +build: [ + [make] + [make "install" "BINDIR=%{bin}%" "SBINDIR=%{bin}%" "LIBEXECDIR=%{bin}%" "SCRIPTSDIR=%{bin}%" "ETCDIR=%{prefix}%/etc"] +] +remove: [make "uninstall" "BINDIR=%{bin}%" "SBINDIR=%{bin}%" "LIBEXECDIR=%{bin}%" "SCRIPTSDIR=%{bin}%" "ETCDIR=%{prefix}%/etc"] +depends: [ + "ocamlfind" + "xapi-idl" + "xapi-libs-transitional" + "xen-api-client" + "xapi-inventory" + "netlink" +] From 2738b79960ecf71286475e5c5c0a80a42a0d231b Mon Sep 17 00:00:00 2001 From: Si Beaumont Date: Thu, 8 Jan 2015 16:10:41 +0000 Subject: [PATCH 061/260] CA-151464: Don't assume interface is bonded if master sysfs key exists In 3.12+ kernels, this key also exists for OVS ports. Signed-off-by: Si Beaumont --- lib/network_utils.ml | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 0b1d60ebb..34b18a99c 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -456,8 +456,13 @@ module Linux_bonding = struct let get_bond_master_of slave = try - let path = Unix.readlink (Sysfs.getpath slave "master") in - Some (List.hd (List.rev (String.split '/' path))) + let master_symlink = Sysfs.getpath slave "master" in + let master_path = Unix.readlink master_symlink in + let slaves_path = Filename.concat master_symlink "bonding/slaves" in + let slaves = Sysfs.read_one_line slaves_path |> String.split ' ' in + if List.mem slave slaves + then Some (List.hd (List.rev (String.split '/' master_path))) + else None with _ -> None end From aab72b58137fbcee986feec6f00d26bed82b8887 Mon Sep 17 00:00:00 2001 From: Si Beaumont Date: Fri, 9 Jan 2015 12:02:11 +0000 Subject: [PATCH 062/260] CA-151464: Don't check the contents of the bond slaves file Signed-off-by: Si Beaumont --- lib/network_utils.ml | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 34b18a99c..be5ded625 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -459,10 +459,8 @@ module Linux_bonding = struct let master_symlink = Sysfs.getpath slave "master" in let master_path = Unix.readlink master_symlink in let slaves_path = Filename.concat master_symlink "bonding/slaves" in - let slaves = Sysfs.read_one_line slaves_path |> String.split ' ' in - if List.mem slave slaves - then Some (List.hd (List.rev (String.split '/' master_path))) - else None + Unix.access slaves_path [ Unix.F_OK ]; + Some (List.hd (List.rev (String.split '/' master_path))) with _ -> None end From f2e9e4a1f66585ff7de1cc71aab55a8903868352 Mon Sep 17 00:00:00 2001 From: Euan Harris Date: Thu, 23 Apr 2015 15:56:10 +0100 Subject: [PATCH 063/260] obuild: Remove xcp-networkd.obuild file Signed-off-by: Euan Harris --- xcp-networkd.obuild | 27 --------------------------- 1 file changed, 27 deletions(-) delete mode 100644 xcp-networkd.obuild diff --git a/xcp-networkd.obuild b/xcp-networkd.obuild deleted file mode 100644 index 8b0ff8195..000000000 --- a/xcp-networkd.obuild +++ /dev/null @@ -1,27 +0,0 @@ -name: xcp-networkd -version: 0.9.1 -synopsis: XCP Network Daemon -obuild-ver: 1 - -library network-libs - src-dir: lib - modules: network_config, network_utils - build-deps: forkexec, stdext, threads, rpclib, stdext, xcp-inventory, xcp.network - cdir: lib - c-sources: link_stubs.c - -executable xcp-networkd - main: networkd.ml - src-dir: networkd - build-deps: threads, rpclib, rpclib.unix, forkexec, stdext, xcp-inventory, network-libs, xen-api-client, xcp, xcp.network, netlink - pp: camlp4o - -executable networkd_db - main: networkd_db.ml - src-dir: networkd_db - build-deps: network-libs, stdext, threads, xcp.network - -test network_test - main: network_test.ml - src-dir: test - build-deps: stdext, oUnit, network-libs From 71a70b1dd64f475fd69c6dd7b136715e878ce1ac Mon Sep 17 00:00:00 2001 From: Koushik Chakravarty Date: Thu, 11 Jun 2015 07:36:09 +0000 Subject: [PATCH 064/260] CP-9895: Added originator for xapi login_with_password The login_with_password XenAPI call takes an "originator" string as its fourth parameter. If a client does this, then it gets its own pool of xapi sessions. Moreover it will not have its xapi sessions destroyed prematurely as a result of some other misbehaving client that keeps creating sessions and not logging out of them. This patch adds the "originator" to all invokes of login_with_password. Signed-off-by: Koushik Chakravarty --- networkd/network_monitor_thread.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index 91b8605b9..2597129d0 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -35,7 +35,7 @@ let send_bond_change_alert dev interfaces message = let ifaces = String.concat "+" (List.sort String.compare interfaces) in let module XenAPI = Client.Client in let session_id = XenAPI.Session.login_with_password - ~rpc:xapi_rpc ~uname:"" ~pwd:"" ~version:"1.4" in + ~rpc:xapi_rpc ~uname:"" ~pwd:"" ~version:"1.4" ~originator:("xcp-networkd v" ^ Version.version) in Pervasiveext.finally (fun _ -> let obj_uuid = Inventory.lookup Inventory._installation_uuid in From a33b0dd0c4e07c8fd6b3f2d3f477b9f26e52d9a5 Mon Sep 17 00:00:00 2001 From: Ravi Pandey Date: Wed, 17 Jun 2015 13:04:09 +0000 Subject: [PATCH 065/260] CA-113824: Prevent "xenapi" prefixed bridge monitoring This patch also refactors the code for getting the prefix interfaces that we do not want to be monitored. It now gets the list of prefixes from xcp-networkd-conf file. Also, it adds an example config file. Signed-off-by: Ravi Pandey --- networkd/network_monitor_thread.ml | 28 +++++++++++++++++++--------- networkd/networkd.ml | 7 ++++++- xcp-networkd.conf | 20 ++++++++++++++++++++ 3 files changed, 45 insertions(+), 10 deletions(-) create mode 100644 xcp-networkd.conf diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index 91b8605b9..f5e79d380 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -25,6 +25,14 @@ open D (** Table for bonds status. *) let bonds_status : (string, (int * int)) Hashtbl.t = Hashtbl.create 10 +let monitor_blacklist = ref [ + "dummy"; + "xenbr"; + "xapi"; + "ovs-system"; + "xenapi"; +] + let xapi_rpc request = Rpc_client.do_rpc_unix ~content_type:(Rpc_client.content_type_of_string "text/xml") @@ -98,8 +106,17 @@ let get_link_stats () = let cache = Link.cache_alloc s in let links = Link.cache_to_list cache in - let devs = List.map (fun link -> - let name = standardise_name (Link.get_name link) in + let links = + List.map (fun link -> + (standardise_name (Link.get_name link)), link + ) links |> + List.filter (fun (name,link) -> + let is_monitor_blacklisted = List.exists (fun s -> String.startswith s name) !monitor_blacklist || + (String.startswith "eth" name && String.contains name '.') in + not is_monitor_blacklisted + ) in + + let devs = List.map (fun (name,link) -> let convert x = Int64.of_int (Unsigned.UInt64.to_int x) in let eth_stat = {default_stats with rx_bytes = Link.get_stat link Link.RX_BYTES |> convert; @@ -111,13 +128,6 @@ let get_link_stats () = } in name, eth_stat ) links in - let devs = List.filter (fun (name, _) -> - not(String.startswith "dummy" name) && - not(String.startswith "xenbr" name) && - not(String.startswith "xapi" name) && - not(String.startswith "eth" name && String.contains name '.') && - name <> "ovs-system" - ) devs in Cache.free cache; Socket.close s; diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 801d28279..4426f06d2 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -15,6 +15,7 @@ open Pervasiveext open Fun open Network_utils +open Xstringext module D = Debug.Make(struct let name = "networkd" end) open D @@ -42,6 +43,10 @@ let resources = [ } ] +let options = [ + "monitor_blacklist", Arg.String (fun x -> Network_monitor_thread.monitor_blacklist := String.split ',' x), (fun () -> String.concat "," !Network_monitor_thread.monitor_blacklist), "List of prefixes of interface names that are not to be monitored"; +] + let start server = Network_monitor_thread.start (); Network_server.on_startup (); @@ -70,7 +75,7 @@ let _ = begin match Xcp_service.configure2 ~name:Sys.argv.(0) ~version:Version.version - ~doc ~resources () with + ~doc ~options ~resources () with | `Ok () -> () | `Error m -> Printf.fprintf stderr "%s\n" m; diff --git a/xcp-networkd.conf b/xcp-networkd.conf new file mode 100644 index 000000000..1e7e9d04a --- /dev/null +++ b/xcp-networkd.conf @@ -0,0 +1,20 @@ +# Configuration file for xcp-networkd + +# Default paths to search for binaries +# search-path= + +# The location of the inventory file +#inventory = /etc/xensource-inventory + +# True to use the message switch; false for direct Unix domain socket +# comms +#use-switch = false + +#The location of brctl tool +#brctl=/usr/sbin/brctl + +# The location for network config file in host +#network-conf=/etc/xensource/network.conf + +#The list of prefix interfaces that are not to be monitored +#monitor-blacklist=dummy,xenbr,xapi,ovs-system,xenapi From c7a07de8c64823d74e243344cd1ae3337c66cbbc Mon Sep 17 00:00:00 2001 From: sharad yadav Date: Mon, 11 May 2015 16:35:25 +0100 Subject: [PATCH 066/260] CP-12093: Add fcoe_driver interface to identify FCoE supported NICs Signed-off-by: sharad yadav --- lib/network_utils.ml | 14 ++++++++++++++ networkd/network_server.ml | 5 +++++ networkd/networkd.ml | 6 ++++++ 3 files changed, 25 insertions(+) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index be5ded625..e80dc7808 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -33,6 +33,7 @@ let modprobe = "/sbin/modprobe" let ethtool = ref "/sbin/ethtool" let bonding_dir = "/proc/net/bonding/" let dhcp6c = "/sbin/dhcp6c" +let fcoedriver = ref "/opt/xensource/libexec/fcoe_driver.py" let call_script ?(log_successful_output=false) script args = try @@ -546,6 +547,19 @@ module Dhclient = struct end end +module Fcoe = struct + let call ?(log=false) args = + call_script ~log_successful_output:log !fcoedriver args + + let get_capabilities name = + try + let output = call [name; "capable"] in + if String.has_substr output "True" then ["fcoe"] else [] + with _ -> + debug "Failed to get fcoe support status on device %s" name; + [] +end + module Sysctl = struct let write value variable = ignore (call_script ~log_successful_output:true sysctl ["-q"; "-w"; variable ^ "=" ^ value]) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index d57f18cd4..514b62c42 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -317,6 +317,11 @@ module Interface = struct Ethtool.set_offload name params ) () + let get_capabilities _ dbg ~name = + Debug.with_thread_associated dbg (fun () -> + Fcoe.get_capabilities name + ) () + let is_connected _ dbg ~name = Debug.with_thread_associated dbg (fun () -> Sysfs.get_carrier name diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 4426f06d2..d53ed6396 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -40,6 +40,12 @@ let resources = [ essential = true; path = Network_utils.ethtool; perms = [ Unix.X_OK ]; + }; + { Xcp_service.name = "fcoedriver"; + description = "used to identify fcoe interfaces"; + essential = false; + path = Network_utils.fcoedriver; + perms = [ Unix.X_OK ]; } ] From 63150de8e8080d49a3e98cb3bc8a92bbf6a89dea Mon Sep 17 00:00:00 2001 From: Sharad Yadav Date: Thu, 2 Jul 2015 17:05:42 +0100 Subject: [PATCH 067/260] Use new path for fcoe driver Signed-off-by: Sharad Yadav --- lib/network_utils.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index e80dc7808..2d84297a2 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -33,7 +33,7 @@ let modprobe = "/sbin/modprobe" let ethtool = ref "/sbin/ethtool" let bonding_dir = "/proc/net/bonding/" let dhcp6c = "/sbin/dhcp6c" -let fcoedriver = ref "/opt/xensource/libexec/fcoe_driver.py" +let fcoedriver = ref "/opt/xensource/libexec/fcoe_driver" let call_script ?(log_successful_output=false) script args = try From ce16445424693a047349b4b9c354c4ed98d5fca6 Mon Sep 17 00:00:00 2001 From: Sharad Yadav Date: Thu, 2 Jul 2015 17:07:54 +0100 Subject: [PATCH 068/260] Use a switch `--xapi` to call fcoe driver Signed-off-by: Sharad Yadav --- lib/network_utils.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 2d84297a2..644ad76ec 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -553,7 +553,7 @@ module Fcoe = struct let get_capabilities name = try - let output = call [name; "capable"] in + let output = call ["--xapi"; name; "capable"] in if String.has_substr output "True" then ["fcoe"] else [] with _ -> debug "Failed to get fcoe support status on device %s" name; From eeab142e91893a315eabda991ab53452b05b971a Mon Sep 17 00:00:00 2001 From: David Scott Date: Fri, 14 Aug 2015 20:36:27 +0100 Subject: [PATCH 069/260] Prepare to release 0.10.0 Signed-off-by: David Scott --- ChangeLog | 5 +++++ _oasis | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 9be82b35f..ad0084a53 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +0.10.0 (14-Aug-2015): +* Preliminary support for FCoE +* Support xapi `originator` +* Prevent "xenapi" prefixed bridge monitoring + 0.9.5 (27-Sep-2014): * Add man page and standard command-line options * Use libnl to read stats from interfaces diff --git a/_oasis b/_oasis index 3b0ee2f28..5e7c0a3a1 100644 --- a/_oasis +++ b/_oasis @@ -1,6 +1,6 @@ OASISFormat: 0.3 Name: xcp-networkd -Version: 0.9.5 +Version: 0.10.0 Synopsis: XCP Network Daemon Authors: Rob Hoes License: LGPL-2.1 with OCaml linking exception From 4f1d2b4066573cf9d721488ff908a75dffec597b Mon Sep 17 00:00:00 2001 From: David Scott Date: Fri, 14 Aug 2015 20:36:31 +0100 Subject: [PATCH 070/260] Regenerate OASIS Signed-off-by: David Scott --- _tags | 87 +++++++-------- lib/META | 4 +- myocamlbuild.ml | 106 ++++++++++-------- setup.ml | 288 +++++++++++++++++++++++++++--------------------- 4 files changed, 267 insertions(+), 218 deletions(-) diff --git a/_tags b/_tags index 9be7e9a7f..e444bba7c 100644 --- a/_tags +++ b/_tags @@ -1,8 +1,9 @@ # OASIS_START -# DO NOT EDIT (digest: 69abe13a880191e9d4ddc9d091092ce0) +# DO NOT EDIT (digest: 24d382d63f193063ab9b3c2a825d1463) # 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 +true: annot, bin_annot <**/.svn>: -traverse <**/.svn>: not_hygienic ".bzr": -traverse @@ -15,15 +16,15 @@ "_darcs": not_hygienic # Library networklibs "lib/networklibs.cmxs": use_networklibs -: oasis_library_networklibs_ccopt +: oasis_library_networklibs_ccopt "lib/link_stubs.c": oasis_library_networklibs_ccopt : use_libnetworklibs_stubs -: pkg_forkexec -: pkg_rpclib -: pkg_stdext -: pkg_threads -: pkg_xcp-inventory -: pkg_xcp.network +: pkg_forkexec +: pkg_rpclib +: pkg_stdext +: pkg_threads +: pkg_xcp-inventory +: pkg_xcp.network "lib/link_stubs.c": pkg_forkexec "lib/link_stubs.c": pkg_rpclib "lib/link_stubs.c": pkg_stdext @@ -42,17 +43,17 @@ : pkg_xcp.network : pkg_xen-api-client : use_networklibs -: pkg_forkexec -: pkg_netlink -: pkg_rpclib -: pkg_rpclib.unix -: pkg_stdext -: pkg_threads -: pkg_xcp -: pkg_xcp-inventory -: pkg_xcp.network -: pkg_xen-api-client -: use_networklibs +: pkg_forkexec +: pkg_netlink +: pkg_rpclib +: pkg_rpclib.unix +: pkg_stdext +: pkg_threads +: pkg_xcp +: pkg_xcp-inventory +: pkg_xcp.network +: pkg_xen-api-client +: use_networklibs : custom # Executable networkd_db : pkg_forkexec @@ -62,13 +63,13 @@ : pkg_xcp-inventory : pkg_xcp.network : use_networklibs -: pkg_forkexec -: pkg_rpclib -: pkg_stdext -: pkg_threads -: pkg_xcp-inventory -: pkg_xcp.network -: use_networklibs +: pkg_forkexec +: pkg_rpclib +: pkg_stdext +: pkg_threads +: pkg_xcp-inventory +: pkg_xcp.network +: use_networklibs : custom # Executable network_test : pkg_forkexec @@ -79,14 +80,14 @@ : pkg_xcp-inventory : pkg_xcp.network : use_networklibs -: pkg_forkexec -: pkg_oUnit -: pkg_rpclib -: pkg_stdext -: pkg_threads -: pkg_xcp-inventory -: pkg_xcp.network -: use_networklibs +: pkg_forkexec +: pkg_oUnit +: pkg_rpclib +: pkg_stdext +: pkg_threads +: pkg_xcp-inventory +: pkg_xcp.network +: use_networklibs # Executable cli : pkg_cmdliner : pkg_forkexec @@ -97,14 +98,14 @@ : pkg_xcp-inventory : pkg_xcp.network : use_networklibs -: pkg_cmdliner -: pkg_forkexec -: pkg_rpclib -: pkg_stdext -: pkg_threads -: pkg_xcp -: pkg_xcp-inventory -: pkg_xcp.network -: use_networklibs +: pkg_cmdliner +: pkg_forkexec +: pkg_rpclib +: pkg_stdext +: pkg_threads +: pkg_xcp +: pkg_xcp-inventory +: pkg_xcp.network +: use_networklibs # OASIS_STOP diff --git a/lib/META b/lib/META index 900fb6d75..d698906fb 100644 --- a/lib/META +++ b/lib/META @@ -1,6 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: 1c79811cc8dd9ea01a505ead32a71432) -version = "0.9.5" +# DO NOT EDIT (digest: de99a9d89799ce8282274091a7a1fc5b) +version = "0.10.0" description = "XCP Network Daemon" requires = "forkexec stdext threads rpclib stdext xcp-inventory xcp.network" archive(byte) = "networklibs.cma" diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 502d9a05d..70c058beb 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 2f48de2146b614fb40f18d31701b8707) *) +(* DO NOT EDIT (digest: 4ff56aec2dfea165b1692e299cedba7e) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) @@ -39,10 +39,10 @@ module OASISExpr = struct open OASISGettext - type test = string + type test = string - type flag = string + type flag = string type t = @@ -52,10 +52,10 @@ module OASISExpr = struct | EOr of t * t | EFlag of flag | ETest of test * string - - type 'a choices = (t * 'a) list + + type 'a choices = (t * 'a) list let eval var_get t = @@ -249,6 +249,9 @@ module MyOCamlbuildFindlib = struct *) open Ocamlbuild_plugin + type conf = + { no_automatic_syntax: bool; + } (* these functions are not really officially exported *) let run_and_read = @@ -315,7 +318,7 @@ module MyOCamlbuildFindlib = struct (* This lists all supported packages. *) let find_packages () = - List.map before_space (split_nl & run_and_read "ocamlfind list") + List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) (* Mock to list available syntaxes. *) @@ -338,7 +341,7 @@ module MyOCamlbuildFindlib = struct ] - let dispatch = + let dispatch conf = function | After_options -> (* By using Before_options one let command line options have an higher @@ -357,31 +360,39 @@ module MyOCamlbuildFindlib = struct * -linkpkg *) flag ["ocaml"; "link"; "program"] & 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 - (* TODO: consider how to really choose camlp4o or camlp4r. *) - 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" || - List.mem pkg well_known_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 ()); + if not (conf.no_automatic_syntax) then begin + (* 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 + (* TODO: consider how to really choose camlp4o or camlp4r. *) + let syn_args = [A"-syntax"; A "camlp4o"] in + let (args, pargs) = + (* Heuristic to identify syntax extensions: whether they end in + ".syntax"; some might not. + *) + if Filename.check_suffix pkg "syntax" || + List.mem pkg well_known_syntax then + (syn_args @ base_args, syn_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; + + (* TODO: Check if this is allowed for OCaml < 3.12.1 *) + flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; + end + (find_packages ()); + end; (* Like -package but for extensions syntax. Morover -syntax is useless * when linking. *) @@ -430,10 +441,10 @@ module MyOCamlbuildBase = struct module OC = Ocamlbuild_pack.Ocaml_compiler - type dir = string - type file = string - type name = string - type tag = string + type dir = string + type file = string + type name = string + type tag = string (* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) @@ -448,7 +459,7 @@ module MyOCamlbuildBase = struct * directory. *) includes: (dir * dir list) list; - } + } let env_filename = @@ -546,12 +557,13 @@ module MyOCamlbuildBase = struct (* When ocaml link something that use the C library, then one need that file to be up to date. + This holds both for programs and for libraries. *) - dep ["link"; "ocaml"; "program"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + dep ["link"; "ocaml"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; - dep ["compile"; "ocaml"; "program"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + dep ["compile"; "ocaml"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; (* TODO: be more specific about what depends on headers *) (* Depends on .h files *) @@ -580,18 +592,18 @@ module MyOCamlbuildBase = struct () - let dispatch_default t = + let dispatch_default conf t = dispatch_combine [ dispatch t; - MyOCamlbuildFindlib.dispatch; + MyOCamlbuildFindlib.dispatch conf; ] end -# 594 "myocamlbuild.ml" +# 606 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { @@ -623,8 +635,10 @@ let package_default = } ;; -let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; +let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} + +let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; -# 629 "myocamlbuild.ml" +# 643 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/setup.ml b/setup.ml index 0e525c3d2..2e4d52e11 100644 --- a/setup.ml +++ b/setup.ml @@ -1,9 +1,9 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 0f4e8b4525108e6ff1e0995a261d587a) *) +(* DO NOT EDIT (digest: 60f46313d4d359dda4540e0275083b1c) *) (* - Regenerated by OASIS v0.4.4 + Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) @@ -242,11 +242,9 @@ module OASISString = struct let replace_chars f s = - let buf = String.make (String.length s) 'X' in - for i = 0 to String.length s - 1 do - buf.[i] <- f s.[i] - done; - buf + let buf = Buffer.create (String.length s) in + String.iter (fun c -> Buffer.add_char buf (f c)) s; + Buffer.contents buf end @@ -739,7 +737,7 @@ module OASISVersion = struct type s = string - type t = string + type t = string type comparator = @@ -750,7 +748,7 @@ module OASISVersion = struct | VLesserEqual of t | VOr of comparator * comparator | VAnd of comparator * comparator - + (* Range of allowed characters *) @@ -945,17 +943,17 @@ module OASISLicense = struct - type license = string + type license = string - type license_exception = string + type license_exception = string type license_version = | Version of OASISVersion.t | VersionOrLater of OASISVersion.t | NoVersion - + type license_dep_5_unit = @@ -964,19 +962,19 @@ module OASISLicense = struct excption: license_exception option; version: license_version; } - + type license_dep_5 = | DEP5Unit of license_dep_5_unit | DEP5Or of license_dep_5 list | DEP5And of license_dep_5 list - + type t = | DEP5License of license_dep_5 | OtherLicense of string (* URL *) - + end @@ -991,10 +989,10 @@ module OASISExpr = struct open OASISGettext - type test = string + type test = string - type flag = string + type flag = string type t = @@ -1004,10 +1002,10 @@ module OASISExpr = struct | EOr of t * t | EFlag of flag | ETest of test * string - - type 'a choices = (t * 'a) list + + type 'a choices = (t * 'a) list let eval var_get t = @@ -1089,9 +1087,9 @@ module OASISText = struct | Para of string | Verbatim of string | BlankLine - - type t = elt list + + type t = elt list end @@ -1102,40 +1100,40 @@ module OASISTypes = struct - type name = string - type package_name = string - type url = string - type unix_dirname = string - type unix_filename = string - type host_dirname = string - type host_filename = string - type prog = string - type arg = string - type args = string list - type command_line = (prog * arg list) + type name = string + type package_name = string + type url = string + type unix_dirname = string + type unix_filename = string + type host_dirname = string + type host_filename = string + type prog = string + type arg = string + type args = string list + type command_line = (prog * arg list) - type findlib_name = string - type findlib_full = string + type findlib_name = string + type findlib_full = string type compiled_object = | Byte | Native | Best - + type dependency = | FindlibPackage of findlib_full * OASISVersion.comparator option | InternalLibrary of name - + type tool = | ExternalTool of name | InternalExecutable of name - + type vcs = @@ -1148,7 +1146,7 @@ module OASISTypes = struct | Arch | Monotone | OtherVCS of url - + type plugin_kind = @@ -1176,7 +1174,7 @@ module OASISTypes = struct ] - type 'a plugin = 'a * name * OASISVersion.t option + type 'a plugin = 'a * name * OASISVersion.t option type all_plugin = plugin_kind plugin @@ -1188,7 +1186,7 @@ module OASISTypes = struct (* # 115 "src/oasis/OASISTypes.ml" *) - type 'a conditional = 'a OASISExpr.choices + type 'a conditional = 'a OASISExpr.choices type custom = @@ -1196,7 +1194,7 @@ module OASISTypes = struct pre_command: (command_line option) conditional; post_command: (command_line option) conditional; } - + type common_section = @@ -1205,7 +1203,7 @@ module OASISTypes = struct cs_data: PropList.Data.t; cs_plugin_data: plugin_data; } - + type build_section = @@ -1225,7 +1223,7 @@ module OASISTypes = struct bs_byteopt: args conditional; bs_nativeopt: args conditional; } - + type library = @@ -1236,28 +1234,28 @@ module OASISTypes = struct lib_findlib_parent: findlib_name option; lib_findlib_name: findlib_name option; 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; - } + } type flag = { flag_description: string option; flag_default: bool conditional; - } + } type source_repository = @@ -1269,7 +1267,7 @@ module OASISTypes = struct src_repo_branch: string option; src_repo_tag: string option; src_repo_subdir: unix_filename option; - } + } type test = @@ -1280,7 +1278,7 @@ module OASISTypes = struct test_working_directory: unix_filename option; test_run: bool conditional; test_tools: tool list; - } + } type doc_format = @@ -1291,7 +1289,7 @@ module OASISTypes = struct | Info of unix_filename | DVI | OtherDoc - + type doc = @@ -1307,7 +1305,7 @@ module OASISTypes = struct doc_format: doc_format; doc_data_files: (unix_filename * unix_filename option) list; doc_build_tools: tool list; - } + } type section = @@ -1318,7 +1316,7 @@ module OASISTypes = struct | SrcRepo of common_section * source_repository | Test of common_section * test | Doc of common_section * doc - + type section_kind = @@ -1363,7 +1361,7 @@ module OASISTypes = struct disable_oasis_section: unix_filename list; schema_data: PropList.Data.t; plugin_data: plugin_data; - } + } end @@ -1729,6 +1727,13 @@ module OASISFeatures = struct (fun () -> s_ "Allows the OASIS section comments and digest to be omitted in \ generated files.") + + let no_automatic_syntax = + create "no_automatic_syntax" alpha + (fun () -> + s_ "Disable the automatic inclusion of -syntax camlp4o for packages \ + that matches the internal heuristic (if a dependency ends with \ + a .syntax or is a well known syntax).") end module OASISUnixPath = struct @@ -2099,16 +2104,6 @@ module OASISLibrary = struct lst in - (* The headers that should be compiled along *) - let headers = - if lib.lib_pack then - [] - else - find_modules - lib.lib_modules - "cmi" - in - (* The .cmx that be compiled along *) let cmxs = let should_be_built = @@ -2134,12 +2129,32 @@ module OASISLibrary = struct [] in + (* The headers and annot/cmt files that should be compiled along *) + let headers = + let sufx = + if lib.lib_pack + then [".cmti"; ".cmt"; ".annot"] + else [".cmi"; ".cmti"; ".cmt"; ".annot"] + in + List.map + begin + List.fold_left + begin fun accu s -> + let dot = String.rindex s '.' in + let base = String.sub s 0 dot in + List.map ((^) base) sufx @ accu + end + [] + end + (find_modules lib.lib_modules "cmi") + in + (* Compute what libraries should be built *) let acc_nopath = (* Add the packed header file if required *) let add_pack_header acc = if lib.lib_pack then - [cs.cs_name^".cmi"] :: acc + [cs.cs_name^".cmi"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: acc else acc in @@ -2499,13 +2514,13 @@ module OASISFindlib = struct in let library_name_of_findlib_name = - Lazy.lazy_from_fun - (fun () -> - (* Revert findlib_name_of_library_name. *) - MapString.fold - (fun k v mp -> MapString.add v k mp) - fndlb_name_of_lib_name - MapString.empty) + lazy begin + (* Revert findlib_name_of_library_name. *) + MapString.fold + (fun k v mp -> MapString.add v k mp) + fndlb_name_of_lib_name + MapString.empty + end in let library_name_of_findlib_name fndlb_nm = try @@ -2875,7 +2890,7 @@ module OASISFileUtil = struct end -# 2878 "setup.ml" +# 2893 "setup.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) @@ -2980,7 +2995,7 @@ module BaseEnvLight = struct end -# 2983 "setup.ml" +# 2998 "setup.ml" module BaseContext = struct (* # 22 "src/base/BaseContext.ml" *) @@ -5391,7 +5406,7 @@ module BaseSetup = struct end -# 5394 "setup.ml" +# 5409 "setup.ml" module InternalConfigurePlugin = struct (* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) @@ -5827,6 +5842,17 @@ module InternalInstallPlugin = struct lst in + let make_fnames modul sufx = + List.fold_right + begin fun sufx accu -> + (String.capitalize modul ^ sufx) :: + (String.uncapitalize modul ^ sufx) :: + accu + end + sufx + [] + in + (** Install all libraries *) let install_libs pkg = @@ -5847,27 +5873,29 @@ module InternalInstallPlugin = struct 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 library %s") - modul cs.cs_name; - acc - end) + begin fun acc modul -> + begin + try + [List.find + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + (make_fnames modul [".mli"; ".ml"]))] + with Not_found -> + warning + (f_ "Cannot find source header for module %s \ + in library %s") + modul cs.cs_name; + [] + end + @ + List.filter + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + (make_fnames modul [".annot";".cmti";".cmt"])) + @ acc + end acc lib.lib_modules in @@ -5915,27 +5943,29 @@ module InternalInstallPlugin = struct 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) + begin fun acc modul -> + begin + try + [List.find + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + (make_fnames modul [".mli"; ".ml"]))] + with Not_found -> + warning + (f_ "Cannot find source header for module %s \ + in object %s") + modul cs.cs_name; + [] + end + @ + List.filter + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + (make_fnames modul [".annot";".cmti";".cmt"])) + @ acc + end acc obj.obj_modules in @@ -6240,7 +6270,7 @@ module InternalInstallPlugin = struct end -# 6243 "setup.ml" +# 6273 "setup.ml" module OCamlbuildCommon = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) @@ -6257,7 +6287,7 @@ module OCamlbuildCommon = struct - type extra_args = string list + type extra_args = string list let ocamlbuild_clean_ev = "ocamlbuild-clean" @@ -6298,6 +6328,11 @@ module OCamlbuildCommon = struct else []; + if bool_of_string (tests ()) then + ["-tag"; "tests"] + else + []; + if bool_of_string (profile ()) then ["-tag"; "profile"] else @@ -6574,7 +6609,7 @@ module OCamlbuildDocPlugin = struct { extra_args: string list; run_path: unix_filename; - } + } let doc_build run pkg (cs, doc) argv = @@ -6613,7 +6648,7 @@ module OCamlbuildDocPlugin = struct end -# 6616 "setup.ml" +# 6651 "setup.ml" module CustomPlugin = struct (* # 22 "src/plugins/custom/CustomPlugin.ml" *) @@ -6636,7 +6671,7 @@ module CustomPlugin = struct cmd_main: command_line conditional; cmd_clean: (command_line option) conditional; cmd_distclean: (command_line option) conditional; - } + } let run = BaseCustom.run @@ -6761,7 +6796,7 @@ module CustomPlugin = struct end -# 6764 "setup.ml" +# 6799 "setup.ml" open OASISTypes;; let setup_t = @@ -6816,7 +6851,7 @@ let setup_t = alpha_features = []; beta_features = []; name = "xcp-networkd"; - version = "0.9.5"; + version = "0.10.0"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit @@ -7069,9 +7104,8 @@ let setup_t = plugin_data = [] }; oasis_fn = Some "_oasis"; - oasis_version = "0.4.4"; - oasis_digest = - Some "\127\155O\248\207\197\249R\171\219\154\237\180\196\002\164"; + oasis_version = "0.4.5"; + oasis_digest = Some "\137l�\024�\b��\030\0115�\"\156�"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7079,6 +7113,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7083 "setup.ml" +# 7117 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 14121093ba78e134733d58eb96bcb7637e47baae Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Wed, 4 Nov 2015 15:23:12 +0000 Subject: [PATCH 071/260] Remove init script There is one (two?) in xen-api-libs-specs already, which is confusing. Signed-off-by: Rob Hoes --- scripts/init.d-networkd | 99 ----------------------------------------- 1 file changed, 99 deletions(-) delete mode 100644 scripts/init.d-networkd diff --git a/scripts/init.d-networkd b/scripts/init.d-networkd deleted file mode 100644 index e4a32b2b0..000000000 --- a/scripts/init.d-networkd +++ /dev/null @@ -1,99 +0,0 @@ -#! /bin/bash -# -# xcp-networkd Start/Stop the XCP networking daemon -# -# chkconfig: 2345 13 76 -# description: XCP networking daemon -# processname: xcp-networkd -# pidfile: /var/run/xcp-networkd.pid - -# Source function library. -. /etc/init.d/functions - -# v6 licensing daemon - -# location of the executable: -NETWORKD="@LIBEXECDIR@/xcp-networkd" - -# pidfile: -PID_FILE="/var/run/xcp-networkd.pid" - -# lock file -SUBSYS_FILE="/var/lock/subsys/xcp-networkd" - -start() { - echo -n $"Starting the XCP networking daemon: " - - if [ -e ${SUBSYS_FILE} ]; then - if [ -e ${PID_FILE} ] && [ -e /proc/`cat ${PID_FILE}` ]; then - echo -n $"cannot start xcp-networkd: already running." - failure $"cannot start xcp-networkd: already running." - echo - return 1 - fi - fi - - # Enable backtraces - export OCAMLRUNPARAM="b" - - ${NETWORKD} -daemon true -pidfile ${PID_FILE} >/dev/null 2>&1 /dev/null) - kill -0 ${PID} 2> /dev/null - if [ $? -eq 0 ]; then - touch ${SUBSYS_FILE} - success - echo - return 0 - fi - sleep 1 - echo -n . - RETRY=$(( ${RETRY} + 1 )) - done - echo -n $"failed to start xcp-networkd." - failure $"failed to start xcp-networkd." - killproc xcp-networkd - rm -f ${SUBSYS_FILE} ${PID_FILE} - echo - return 1 -} - -stop() { - echo -n $"Stopping the XCP networking daemon: " - - if [ ! -e ${SUBSYS_FILE} ]; then - echo -n $"cannot stop xcp-networkd: daemon is not running." - failure $"cannot stop xcp-networkd: daemon is not running." - echo - return 1; - fi - - killproc xcp-networkd - RETVAL=$? - echo - [ $RETVAL -eq 0 ] && rm -f ${SUBSYS_FILE} ${PID_FILE} - return $RETVAL -} - -restart() { - stop - start -} - -case "$1" in - start) - start - ;; - stop) - stop - ;; - restart) - restart - ;; - *) - echo $"Usage: $0 {start|stop|restart}" - exit 1 -esac From 1e07bfc9c9048f06ec3aa2f27e217abcc25b8d18 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Thu, 12 Nov 2015 22:48:56 +0000 Subject: [PATCH 072/260] CA-184010: Add a timeout to script invocations Signed-off-by: Jon Ludlam --- lib/network_utils.ml | 30 ++++++++++++++---------------- 1 file changed, 14 insertions(+), 16 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 644ad76ec..d0d03cfaf 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -35,32 +35,30 @@ let bonding_dir = "/proc/net/bonding/" let dhcp6c = "/sbin/dhcp6c" let fcoedriver = ref "/opt/xensource/libexec/fcoe_driver" -let call_script ?(log_successful_output=false) script args = +let call_script ?(log_successful_output=false) ?(timeout=60.0) script args = try Unix.access script [ Unix.X_OK ]; (* Use the same $PATH as xapi *) let env = [| "PATH=" ^ (Sys.getenv "PATH") |] in info "%s %s" script (String.concat " " args); - - let readme, writeme = Unix.pipe () in - let pid = Forkhelpers.safe_close_and_exec ~env None (Some writeme) None [] script args in - Unix.close writeme; - (* assume output is never larger than a pipe buffer *) - let (_: (int * Unix.process_status)) = Forkhelpers.waitpid pid in - let output = String.make 16384 '\000' in - let n = Unix.read readme output 0 (String.length output) in - Unix.close readme; - String.sub output 0 n + let (out,err) = Forkhelpers.execute_command_get_output ~env ~timeout script args in + out with | Unix.Unix_error (e, a, b) -> error "Caught unix error: %s [%s, %s]" (Unix.error_message e) a b; error "Assuming script %s doesn't exist" script; raise (Script_missing script) - | Forkhelpers.Spawn_internal_error(stderr, stdout, Unix.WEXITED n)-> - error "Call '%s %s' exited with code %d [stdout = '%s'; stderr = '%s']" script - (String.concat " " args) n stdout stderr; + | Forkhelpers.Spawn_internal_error(stderr, stdout, e)-> + let message = + match e with + | Unix.WEXITED n -> Printf.sprintf "Exit code %d" n + | Unix.WSIGNALED s -> Printf.sprintf "Signaled %d" s (* Note that this is the internal ocaml signal number, see Sys module *) + | Unix.WSTOPPED s -> Printf.sprintf "Stopped %d" s + in + error "Call '%s %s' exited badly: %s [stdout = '%s'; stderr = '%s']" script + (String.concat " " args) message stdout stderr; raise (Script_error ["script", script; "args", String.concat " " args; "code", - string_of_int n; "stdout", stdout; "stderr", stderr]) + message; "stdout", stdout; "stderr", stderr]) module Sysfs = struct let list () = @@ -549,7 +547,7 @@ end module Fcoe = struct let call ?(log=false) args = - call_script ~log_successful_output:log !fcoedriver args + call_script ~log_successful_output:log ~timeout:10.0 !fcoedriver args let get_capabilities name = try From 9f92b5e4c7ffe4fb2c442001e043a3ebfb7f5246 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Wed, 2 Dec 2015 14:52:59 +0000 Subject: [PATCH 073/260] Don't use a timeout when executing dhclient Dhclient has a built-in timeout of its own, after which is backgrounds itself and unblocks the caller. We don't want dhclient to get killed by networkd after some arbitrary timeout. Signed-off-by: Rob Hoes --- lib/network_utils.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index d0d03cfaf..17722e275 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -35,13 +35,13 @@ let bonding_dir = "/proc/net/bonding/" let dhcp6c = "/sbin/dhcp6c" let fcoedriver = ref "/opt/xensource/libexec/fcoe_driver" -let call_script ?(log_successful_output=false) ?(timeout=60.0) script args = +let call_script ?(log_successful_output=false) ?(timeout=Some 60.0) script args = try Unix.access script [ Unix.X_OK ]; (* Use the same $PATH as xapi *) let env = [| "PATH=" ^ (Sys.getenv "PATH") |] in info "%s %s" script (String.concat " " args); - let (out,err) = Forkhelpers.execute_command_get_output ~env ~timeout script args in + let (out,err) = Forkhelpers.execute_command_get_output ~env ?timeout script args in out with | Unix.Unix_error (e, a, b) -> @@ -509,7 +509,7 @@ module Dhclient = struct | _ -> l) [] options in write_conf_file ~ipv6 interface options; let ipv6' = if ipv6 then ["-6"] else [] in - call_script ~log_successful_output:true dhclient (ipv6' @ gw_opt @ ["-q"; + call_script ~log_successful_output:true ~timeout:None dhclient (ipv6' @ gw_opt @ ["-q"; "-pf"; pid_file ~ipv6 interface; "-lf"; lease_file ~ipv6 interface; "-cf"; conf_file ~ipv6 interface; @@ -547,7 +547,7 @@ end module Fcoe = struct let call ?(log=false) args = - call_script ~log_successful_output:log ~timeout:10.0 !fcoedriver args + call_script ~log_successful_output:log ~timeout:(Some 10.0) !fcoedriver args let get_capabilities name = try From 7e44301b9f22b97537c4723426239b4a4e16230b Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 4 Dec 2015 15:25:00 +0000 Subject: [PATCH 074/260] CA-192116: On startup, each operation must be best effort This means that if we cannot setup one of the bridges, for some reason, we must still try to configure the remaining ones. Signed-off-by: Rob Hoes --- networkd/network_server.ml | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 514b62c42..8a62d8b08 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -380,7 +380,8 @@ module Interface = struct else config in - debug "** Configuring the following interfaces: %s" (String.concat ", " (List.map (fun (name, _) -> name) config)); + debug "** Configuring the following interfaces: %s%s" (String.concat ", " (List.map (fun (name, _) -> name) config)) + (if conservative then " (best effort)" else ""); let exec f = if conservative then (try f () with _ -> ()) else f () in List.iter (function (name, ({ipv4_conf; ipv4_gateway; ipv6_conf; ipv6_gateway; ipv4_routes; dns=nameservers,domains; mtu; ethtool_settings; ethtool_offload; _} as c)) -> @@ -783,14 +784,18 @@ module Bridge = struct config in let config = List.sort vlans_go_last config in - debug "** Configuring the following bridges: %s" - (String.concat ", " (List.map (fun (name, _) -> name) config)); + let exec f = if conservative then (try f () with _ -> ()) else f () in + debug "** Configuring the following bridges: %s%s" + (String.concat ", " (List.map (fun (name, _) -> name) config)) + (if conservative then " (best effort)" else ""); List.iter (function (bridge_name, ({ports; vlan; bridge_mac; other_config; _} as c)) -> update_config bridge_name c; - create () dbg ?vlan ?mac:bridge_mac ~other_config ~name:bridge_name (); - List.iter (fun (port_name, {interfaces; bond_properties; bond_mac}) -> - add_port () dbg ?bond_mac ~bridge:bridge_name ~name:port_name ~interfaces ~bond_properties () - ) ports + exec (fun () -> + create () dbg ?vlan ?mac:bridge_mac ~other_config ~name:bridge_name (); + List.iter (fun (port_name, {interfaces; bond_properties; bond_mac}) -> + add_port () dbg ?bond_mac ~bridge:bridge_name ~name:port_name ~interfaces ~bond_properties () + ) ports + ) ) config ) () end From 45f9d9bfb5498baf60f303dc4979655c63e887bd Mon Sep 17 00:00:00 2001 From: Koushik Chakravarty Date: Fri, 8 Jan 2016 08:04:31 +0000 Subject: [PATCH 075/260] CP-15312: Remove dhcp6 exception from toolstack startup dhclient handles all ipv6 related configurations and hence dhcp6 is not required Signed-off-by: Koushik Chakravarty --- lib/network_utils.ml | 12 ------------ networkd/network_server.ml | 17 +++++++++++------ 2 files changed, 11 insertions(+), 18 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 17722e275..c7c4cb1b2 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -32,7 +32,6 @@ let brctl = ref "/sbin/brctl" let modprobe = "/sbin/modprobe" let ethtool = ref "/sbin/ethtool" let bonding_dir = "/proc/net/bonding/" -let dhcp6c = "/sbin/dhcp6c" let fcoedriver = ref "/opt/xensource/libexec/fcoe_driver" let call_script ?(log_successful_output=false) ?(timeout=Some 60.0) script args = @@ -986,14 +985,3 @@ module Bindings = struct with_fd (fun fd -> _get_status fd name) with _ -> raise (Read_error "stub_link_get_status") end - -module Dhcp6c = struct - let pid_file interface = - Printf.sprintf "/var/run/dhcp6c-%s.pid" interface - - let start interface = - ignore (call_script dhcp6c [interface]) - - let stop interface = - ignore (call_script dhcp6c ["-r"; "all"; interface]) -end diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 8a62d8b08..5e1bab500 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -193,31 +193,36 @@ module Interface = struct match conf with | None6 -> if List.mem name (Sysfs.list ()) then begin - Dhcp6c.stop name; + if Dhclient.is_running ~ipv6:true name then + ignore (Dhclient.stop ~ipv6:true name); Sysctl.set_ipv6_autoconf name false; Ip.flush_ip_addr ~ipv6:true name end | Linklocal6 -> if List.mem name (Sysfs.list ()) then begin - Dhcp6c.stop name; + if Dhclient.is_running ~ipv6:true name then + ignore (Dhclient.stop ~ipv6:true name); Sysctl.set_ipv6_autoconf name false; Ip.flush_ip_addr ~ipv6:true name; Ip.set_ipv6_link_local_addr name end | DHCP6 -> - Dhcp6c.stop name; + if Dhclient.is_running ~ipv6:true name then + ignore (Dhclient.stop ~ipv6:true name); Sysctl.set_ipv6_autoconf name false; Ip.flush_ip_addr ~ipv6:true name; Ip.set_ipv6_link_local_addr name; - Dhcp6c.start name + ignore (Dhclient.start ~ipv6:true name []) | Autoconf6 -> - Dhcp6c.stop name; + if Dhclient.is_running ~ipv6:true name then + ignore (Dhclient.stop ~ipv6:true name); Ip.flush_ip_addr ~ipv6:true name; Ip.set_ipv6_link_local_addr name; Sysctl.set_ipv6_autoconf name true; (* Cannot link set down/up due to CA-89882 - IPv4 default route cleared *) | Static6 addrs -> - Dhcp6c.stop name; + if Dhclient.is_running ~ipv6:true name then + ignore (Dhclient.stop ~ipv6:true name); Sysctl.set_ipv6_autoconf name false; Ip.flush_ip_addr ~ipv6:true name; Ip.set_ipv6_link_local_addr name; From 118ae6fb1039e4a1407d35bd938aea15f55d467d Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 5 Feb 2016 16:33:40 +0000 Subject: [PATCH 076/260] CA-149863: Take bond mode into account when determining bond speed For active-backup bonds, only the so-called "active slave" carries traffic, while the other slaves are on stand-by. For these bonds, we only look at the active slave for metrics such as speed and duplex. Signed-off-by: Rob Hoes --- lib/network_utils.ml | 43 +++++++++++++--- networkd/network_monitor_thread.ml | 81 ++++++++++++++++-------------- networkd/network_server.ml | 38 ++++++++++++++ 3 files changed, 118 insertions(+), 44 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index c7c4cb1b2..0b89cecc3 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -460,6 +460,13 @@ module Linux_bonding = struct Unix.access slaves_path [ Unix.F_OK ]; Some (List.hd (List.rev (String.split '/' master_path))) with _ -> None + + let get_bond_active_slave master = + try + Some (Sysfs.read_one_line (Sysfs.getpath master ("bonding/active_slave"))) + with _ -> + error "Failed to get active_slave of bond %s" master; + None end module Dhclient = struct @@ -673,16 +680,38 @@ module Ovs = struct Some (vsctl ["br-to-parent"; name], int_of_string (vsctl ["br-to-vlan"; name])) with _ -> None - let get_bond_links_up name = + let get_bond_link_status name = try - let check_line line = - if (String.startswith "slave" line) && (String.endswith "enabled" line) then 1 else 0 - in let raw = appctl ["bond/show"; name] in let lines = String.split '\n' raw in - let nb_links = List.fold_left (fun acc line -> acc + (check_line line)) 0 lines in - nb_links - with _ -> 0 + List.fold_left (fun (slaves, active_slave) line -> + let slaves = + try + Scanf.sscanf line "slave %s@: %s" (fun slave state -> + (slave, state = "enabled") :: slaves + ) + with _ -> slaves + in + let active_slave = + try + Scanf.sscanf line "active slave %s@(%s@)" (fun _ slave -> Some slave) + with _ -> active_slave + in + slaves, active_slave + ) ([], None) lines + with _ -> [], None + + let get_bond_links_up name = + let slaves, _ = get_bond_link_status name in + let links_up = List.filter snd slaves in + List.length (links_up) + + let get_bond_mode name = + try + let output = String.rtrim (vsctl ["get"; "port"; name; "bond_mode"]) in + if output <> "[]" then Some output else None + with _ -> + None let set_max_idle t = try diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index 8b0986402..063b6172f 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -177,57 +177,64 @@ let rec monitor dbg () = transform_taps (); - let bonds_list = ref [] in devs := List.map (fun (dev, stat) -> if not (String.startswith "vif" dev) then begin - let devs = + let open Network_server.Bridge in + let bond_slaves = if List.mem_assoc dev bonds then - List.assoc dev bonds + get_bond_link_info () dbg dev else - [dev] + [] in - let vendor_id, device_id = if List.length devs = 1 then Sysfs.get_pci_ids dev else "", "" in - let carriers = List.map Sysfs.get_carrier devs in - let speed, duplex = - let combine_duplex = function - | Duplex_full, Duplex_full -> Duplex_full - | Duplex_unknown, a | a, Duplex_unknown -> a - | _ -> Duplex_half - in - List.fold_left2 (fun (speed, duplex) dev carrier -> - try - if not carrier then - speed, duplex + let stat = + if bond_slaves = [] then + let carrier = Sysfs.get_carrier dev in + let speed, duplex = + if carrier then + try Bindings.get_status dev with _ -> (0, Duplex_unknown) else - let speed', duplex' = Bindings.get_status dev in - speed + speed', combine_duplex (duplex, duplex') - with _ -> - speed, duplex - ) (0, Duplex_unknown) devs carriers - in - let nb_links = List.length devs in - let carrier = List.mem true carriers in - let get_interfaces name = - let bonds = Network_server.Bridge.get_all_bonds () dbg ~from_cache:true () in - let interfaces = (try List.assoc dev bonds with _ -> []) in - interfaces in - let (links_up,interfaces) = (if nb_links > 1 then - (bonds_list := dev :: !bonds_list; - Network_server.Bridge.get_bond_links_up () dbg dev, get_interfaces dev) + (0, Duplex_unknown) + in + let pci_bus_path = Sysfs.get_pcibuspath dev in + let vendor_id, device_id = Sysfs.get_pci_ids dev in + let nb_links = 1 in + let links_up = if carrier then 1 else 0 in + let interfaces = [dev] in + {stat with carrier; speed; duplex; pci_bus_path; vendor_id; device_id; nb_links; links_up; interfaces} else - ((if carrier then 1 else 0), [dev])) + let carrier = List.exists (fun info -> info.up) bond_slaves in + let speed, duplex = + let combine_duplex = function + | Duplex_full, Duplex_full -> Duplex_full + | Duplex_unknown, a | a, Duplex_unknown -> a + | _ -> Duplex_half + in + List.fold_left (fun (speed, duplex) info -> + try + if info.active then + let speed', duplex' = Bindings.get_status info.slave in + speed + speed', combine_duplex (duplex, duplex') + else + speed, duplex + with _ -> + speed, duplex + ) (0, Duplex_unknown) bond_slaves + in + let pci_bus_path = "" in + let vendor_id, device_id = "", "" in + let nb_links = List.length bond_slaves in + let links_up = List.length (List.filter (fun info -> info.up) bond_slaves) in + let interfaces = List.map (fun info -> info.slave) bond_slaves in + {stat with carrier; speed; duplex; pci_bus_path; vendor_id; device_id; nb_links; links_up; interfaces} in - let pci_bus_path = if List.length devs = 1 then Sysfs.get_pcibuspath dev else "" in - let stat = {stat with carrier; speed; duplex; pci_bus_path; vendor_id; - device_id; nb_links; links_up; interfaces} in check_for_changes ~dev ~stat; dev, stat end else dev, stat ) (!devs); - if (List.length !bonds_list) <> (Hashtbl.length bonds_status) then begin - let dead_bonds = Hashtbl.fold (fun k _ acc -> if List.mem k !bonds_list then acc else k :: acc) + if (List.length bonds) <> (Hashtbl.length bonds_status) then begin + let dead_bonds = Hashtbl.fold (fun k _ acc -> if List.mem_assoc k bonds then acc else k :: acc) bonds_status [] in List.iter (fun b -> info "Removing bond %s" b; Hashtbl.remove bonds_status b) dead_bonds end; diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 5e1bab500..eddc973c9 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -629,6 +629,44 @@ module Bridge = struct | Bridge -> raise Not_implemented ) () + type bond_link_info = { + slave: iface; + up: bool; + active: bool; + } + + let get_bond_link_info _ dbg ~name = + Debug.with_thread_associated dbg (fun () -> + match !backend_kind with + | Openvswitch -> + let slaves, active_slave = Ovs.get_bond_link_status name in + let mode = Ovs.get_bond_mode name in + List.map (fun (slave, up) -> + let active = + let ab = mode = Some "active-backup" in + ab && (active_slave = Some slave) || + (not ab) && up + in + {slave; up; active} + ) slaves + | Bridge -> + let active_slave = Linux_bonding.get_bond_active_slave name in + let slaves = Proc.get_bond_slave_info name "MII Status" in + let bond_props = Linux_bonding.get_bond_properties name in + List.map (fun (slave, status) -> + let up = status = "up" in + let active = + let ab = + List.mem_assoc "mode" bond_props && + String.startswith "active-backup" (List.assoc "mode" bond_props) + in + ab && (active_slave = Some slave) || + (not ab) && up + in + {slave; up; active} + ) slaves + ) () + let get_vlan _ dbg ~name = Debug.with_thread_associated dbg (fun () -> match !backend_kind with From 1685f7826f61d9c249236d33c2dae97eab7f5dd0 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 5 Feb 2016 17:10:50 +0000 Subject: [PATCH 077/260] monitor: eliminate ref and refactor as pipeline Signed-off-by: Rob Hoes --- networkd/network_monitor_thread.ml | 160 +++++++++++++++-------------- 1 file changed, 81 insertions(+), 79 deletions(-) diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index 063b6172f..440f81610 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -138,28 +138,25 @@ let rec monitor dbg () = let open Network_interface in let open Network_monitor in (try - let devs = ref [] in - devs := get_link_stats (); - - let make_bond_info (name, interfaces) = - let devs = List.filter (fun (name', _) -> List.mem name' interfaces) !devs in + let make_bond_info devs (name, interfaces) = + let devs' = List.filter (fun (name', _) -> List.mem name' interfaces) devs in let eth_stat = {default_stats with - rx_bytes = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.rx_bytes) 0L devs; - rx_pkts = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.rx_pkts) 0L devs; - rx_errors = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.rx_errors) 0L devs; - tx_bytes = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.tx_bytes) 0L devs; - tx_pkts = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.tx_pkts) 0L devs; - tx_errors = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.tx_errors) 0L devs; + rx_bytes = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.rx_bytes) 0L devs'; + rx_pkts = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.rx_pkts) 0L devs'; + rx_errors = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.rx_errors) 0L devs'; + tx_bytes = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.tx_bytes) 0L devs'; + tx_pkts = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.tx_pkts) 0L devs'; + tx_errors = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.tx_errors) 0L devs'; } in name, eth_stat in - let bonds : (string * string list) list = Network_server.Bridge.get_all_bonds () dbg ~from_cache:true () in - devs := (List.map make_bond_info bonds) @ !devs; - - let transform_taps () = - let newdevnames = List.setify (List.map fst !devs) in - let newdevs = List.map (fun name -> - let devs = List.filter (fun (n,x) -> n=name) !devs in + let add_bonds bonds devs = + (List.map (make_bond_info devs) bonds) @ devs + in + let transform_taps devs = + let newdevnames = List.setify (List.map fst devs) in + List.map (fun name -> + let devs' = List.filter (fun (n,x) -> n=name) devs in let tot = List.fold_left (fun acc (_,b) -> {default_stats with rx_bytes = Int64.add acc.rx_bytes b.rx_bytes; @@ -167,71 +164,76 @@ let rec monitor dbg () = rx_errors = Int64.add acc.rx_errors b.rx_errors; tx_bytes = Int64.add acc.tx_bytes b.tx_bytes; tx_pkts = Int64.add acc.tx_pkts b.tx_pkts; - tx_errors = Int64.add acc.tx_errors b.tx_errors}) default_stats devs - in + tx_errors = Int64.add acc.tx_errors b.tx_errors} + ) default_stats devs' in (name,tot) ) newdevnames - in - devs := newdevs in - - transform_taps (); - - devs := List.map (fun (dev, stat) -> - if not (String.startswith "vif" dev) then begin - let open Network_server.Bridge in - let bond_slaves = - if List.mem_assoc dev bonds then - get_bond_link_info () dbg dev - else - [] - in - let stat = - if bond_slaves = [] then - let carrier = Sysfs.get_carrier dev in - let speed, duplex = - if carrier then - try Bindings.get_status dev with _ -> (0, Duplex_unknown) - else - (0, Duplex_unknown) - in - let pci_bus_path = Sysfs.get_pcibuspath dev in - let vendor_id, device_id = Sysfs.get_pci_ids dev in - let nb_links = 1 in - let links_up = if carrier then 1 else 0 in - let interfaces = [dev] in - {stat with carrier; speed; duplex; pci_bus_path; vendor_id; device_id; nb_links; links_up; interfaces} - else - let carrier = List.exists (fun info -> info.up) bond_slaves in - let speed, duplex = - let combine_duplex = function - | Duplex_full, Duplex_full -> Duplex_full - | Duplex_unknown, a | a, Duplex_unknown -> a - | _ -> Duplex_half + let add_other_stats bonds devs = + List.map (fun (dev, stat) -> + if not (String.startswith "vif" dev) then begin + let open Network_server.Bridge in + let bond_slaves = + if List.mem_assoc dev bonds then + get_bond_link_info () dbg dev + else + [] + in + let stat = + if bond_slaves = [] then + let carrier = Sysfs.get_carrier dev in + let speed, duplex = + if carrier then + try Bindings.get_status dev with _ -> (0, Duplex_unknown) + else + (0, Duplex_unknown) in - List.fold_left (fun (speed, duplex) info -> - try - if info.active then - let speed', duplex' = Bindings.get_status info.slave in - speed + speed', combine_duplex (duplex, duplex') - else + let pci_bus_path = Sysfs.get_pcibuspath dev in + let vendor_id, device_id = Sysfs.get_pci_ids dev in + let nb_links = 1 in + let links_up = if carrier then 1 else 0 in + let interfaces = [dev] in + {stat with carrier; speed; duplex; pci_bus_path; vendor_id; device_id; nb_links; links_up; interfaces} + else + let carrier = List.exists (fun info -> info.up) bond_slaves in + let speed, duplex = + let combine_duplex = function + | Duplex_full, Duplex_full -> Duplex_full + | Duplex_unknown, a | a, Duplex_unknown -> a + | _ -> Duplex_half + in + List.fold_left (fun (speed, duplex) info -> + try + if info.active then + let speed', duplex' = Bindings.get_status info.slave in + speed + speed', combine_duplex (duplex, duplex') + else + speed, duplex + with _ -> speed, duplex - with _ -> - speed, duplex - ) (0, Duplex_unknown) bond_slaves - in - let pci_bus_path = "" in - let vendor_id, device_id = "", "" in - let nb_links = List.length bond_slaves in - let links_up = List.length (List.filter (fun info -> info.up) bond_slaves) in - let interfaces = List.map (fun info -> info.slave) bond_slaves in - {stat with carrier; speed; duplex; pci_bus_path; vendor_id; device_id; nb_links; links_up; interfaces} - in - check_for_changes ~dev ~stat; - dev, stat - end else - dev, stat - ) (!devs); + ) (0, Duplex_unknown) bond_slaves + in + let pci_bus_path = "" in + let vendor_id, device_id = "", "" in + let nb_links = List.length bond_slaves in + let links_up = List.length (List.filter (fun info -> info.up) bond_slaves) in + let interfaces = List.map (fun info -> info.slave) bond_slaves in + {stat with carrier; speed; duplex; pci_bus_path; vendor_id; device_id; nb_links; links_up; interfaces} + in + check_for_changes ~dev ~stat; + dev, stat + end else + dev, stat + ) devs + in + + let bonds : (string * string list) list = Network_server.Bridge.get_all_bonds () dbg ~from_cache:true () in + let devs = + get_link_stats () |> + add_bonds bonds |> + transform_taps |> + add_other_stats bonds + in if (List.length bonds) <> (Hashtbl.length bonds_status) then begin let dead_bonds = Hashtbl.fold (fun k _ acc -> if List.mem_assoc k bonds then acc else k :: acc) @@ -239,7 +241,7 @@ let rec monitor dbg () = List.iter (fun b -> info "Removing bond %s" b; Hashtbl.remove bonds_status b) dead_bonds end; - write_stats !devs; + write_stats devs; failed_again := false with e -> if not !failed_again then begin From d49bc77957521ba99751d0b10aa666e7a912cfa5 Mon Sep 17 00:00:00 2001 From: Si Beaumont Date: Fri, 19 Feb 2016 14:12:47 +0000 Subject: [PATCH 078/260] CA-198824: Allow empty DNS when configuring static IP Signed-off-by: Si Beaumont --- networkd/network_server.ml | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index eddc973c9..7a26ece84 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -276,18 +276,17 @@ module Interface = struct let set_dns _ dbg ~name ~nameservers ~domains = Debug.with_thread_associated dbg (fun () -> update_config name {(get_config name) with dns = nameservers, domains}; - if (nameservers <> [] || domains <> []) then begin - debug "Configuring DNS for %s: nameservers: %s; domains: %s" name - (String.concat ", " (List.map Unix.string_of_inet_addr nameservers)) (String.concat ", " domains); - if (!config.dns_interface = None || !config.dns_interface = Some name) then begin - debug "%s is the DNS interface" name; - let domains' = if domains <> [] then ["search " ^ (String.concat " " domains)] else [] in - let nameservers' = List.map (fun ip -> "nameserver " ^ (Unix.string_of_inet_addr ip)) nameservers in - let lines = domains' @ nameservers' in - Unixext.write_string_to_file resolv_conf ((String.concat "\n" lines) ^ "\n") - end else - debug "%s is NOT the DNS interface" name - end + debug "Configuring DNS for %s: nameservers: [%s]; domains: [%s]" name + (String.concat ", " (List.map Unix.string_of_inet_addr nameservers)) + (String.concat ", " domains); + if (!config.dns_interface = None || !config.dns_interface = Some name) then begin + debug "%s is the DNS interface" name; + let domains' = if domains <> [] then ["search " ^ (String.concat " " domains)] else [] in + let nameservers' = List.map (fun ip -> "nameserver " ^ (Unix.string_of_inet_addr ip)) nameservers in + let lines = domains' @ nameservers' in + Unixext.write_string_to_file resolv_conf ((String.concat "\n" lines) ^ "\n") + end else + debug "%s is NOT the DNS interface" name ) () let get_mtu _ dbg ~name = From 5ae538fa284a7dabdc6bd6945f2143b59b1e78b5 Mon Sep 17 00:00:00 2001 From: Si Beaumont Date: Fri, 19 Feb 2016 14:13:26 +0000 Subject: [PATCH 079/260] gitignore: Ignore _build/ output Signed-off-by: Si Beaumont --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 9df49a1cc..8f1bb8547 100644 --- a/.gitignore +++ b/.gitignore @@ -7,3 +7,4 @@ xcp-networkd.1 setup.data setup.log dist/ +_build/ From 1a2383c5c4aca9113962a42e0642935638ca0ccb Mon Sep 17 00:00:00 2001 From: Si Beaumont Date: Mon, 22 Feb 2016 15:11:22 +0000 Subject: [PATCH 080/260] CA-199405: Set DNS before making DHCP request A recent change[1] to support clearing of DNS entries when using Static mode networking has caused DNS entries to be cleared when using DHCP. We need to support the following cases: 1. DHCP; 2. Static with non-empty DNS; and 3. Static with empty DNS. We currently don't support DHCP with a DNS override so we don't need to consider this in this patch. This patch changes the order of setting the DNS for the host and calling dhclient so that the above three use-cases are honoured. [1]: d49bc77 CA-198824: Allow empty DNS when configuring static IP Signed-off-by: Si Beaumont --- networkd/network_server.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 7a26ece84..fec497a39 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -390,6 +390,7 @@ module Interface = struct List.iter (function (name, ({ipv4_conf; ipv4_gateway; ipv6_conf; ipv6_gateway; ipv4_routes; dns=nameservers,domains; mtu; ethtool_settings; ethtool_offload; _} as c)) -> update_config name c; + exec (fun () -> set_dns () dbg ~name ~nameservers ~domains); exec (fun () -> set_ipv4_conf () dbg ~name ~conf:ipv4_conf); exec (fun () -> match ipv4_gateway with None -> () | Some gateway -> set_ipv4_gateway () dbg ~name ~address:gateway); @@ -397,7 +398,6 @@ module Interface = struct (try match ipv6_gateway with None -> () | Some gateway -> set_ipv6_gateway () dbg ~name ~address:gateway with _ -> ()); exec (fun () -> set_ipv4_routes () dbg ~name ~routes:ipv4_routes); - exec (fun () -> set_dns () dbg ~name ~nameservers ~domains); exec (fun () -> set_mtu () dbg ~name ~mtu); exec (fun () -> bring_up () dbg ~name); exec (fun () -> set_ethtool_settings () dbg ~name ~params:ethtool_settings); From 35c45634ac9d114e0a5d3d18ffe90a6a432549c8 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Mon, 22 Feb 2016 21:58:36 +0000 Subject: [PATCH 081/260] CA-199404: Only apply DNS settings in Static4 mode Commit 1a2383c5 did not solve the original problem in case a DHCP config is applied twice consecutively (for example when the PIF is replugged when xapi is restarted). The second time round, the dhclient process is already running and does not reapply the DNS servers after being cleared by the preceeding `set_dns` call. This is still not a great solution. The `dns` field should really be an option type so that we don't have to derive the intention of the caller by looking at other fields. Changing the type, however, would require us to implement some upgrade logic first. Signed-off-by: Rob Hoes --- networkd/network_server.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index fec497a39..bbc52caef 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -390,7 +390,11 @@ module Interface = struct List.iter (function (name, ({ipv4_conf; ipv4_gateway; ipv6_conf; ipv6_gateway; ipv4_routes; dns=nameservers,domains; mtu; ethtool_settings; ethtool_offload; _} as c)) -> update_config name c; - exec (fun () -> set_dns () dbg ~name ~nameservers ~domains); + exec (fun () -> + (* We only apply the DNS settings when in static IPv4 mode to avoid conflicts with DHCP mode. + * The `dns` field should really be an option type so that we don't have to derive the intention + * of the caller by looking at other fields. *) + match ipv4_conf with Static4 _ -> set_dns () dbg ~name ~nameservers ~domains | _ -> ()); exec (fun () -> set_ipv4_conf () dbg ~name ~conf:ipv4_conf); exec (fun () -> match ipv4_gateway with None -> () | Some gateway -> set_ipv4_gateway () dbg ~name ~address:gateway); From 1caa9470e59853674080540387496f0baa21e0ef Mon Sep 17 00:00:00 2001 From: John Else Date: Wed, 2 Mar 2016 11:27:34 +0000 Subject: [PATCH 082/260] CP-15745: Add .travis.yml This will build and test xcp-networkd using the new xenserver-build-env build scripts. Signed-off-by: John Else --- .travis.yml | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 .travis.yml diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 000000000..7d852f87a --- /dev/null +++ b/.travis.yml @@ -0,0 +1,12 @@ +language: c +services: docker +install: + - wget https://raw.githubusercontent.com/xenserver/xenserver-build-env/master/utils/travis-build-repo.sh +script: bash travis-build-repo.sh +sudo: true +env: + global: + - REPO_PACKAGE_NAME=xcp-networkd + - REPO_CONFIGURE_CMD=true + - REPO_BUILD_CMD=make + - REPO_TEST_CMD='make test' From 98bc6a44ab7163d11bdb81f0d5221636937d9175 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 18 Mar 2016 17:30:19 +0000 Subject: [PATCH 083/260] CA-203180: Linux bridge: disable IGMP snooping by default Signed-off-by: Rob Hoes --- lib/network_utils.ml | 7 +++++++ networkd/network_server.ml | 1 + 2 files changed, 8 insertions(+) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 0b89cecc3..ebe4e8883 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -152,6 +152,13 @@ module Sysfs = struct | None -> false | Some features -> (features land flag_NETIF_F_VLAN) <> 0 + let set_multicast_snooping bridge value = + try + let path = getpath bridge "bridge/multicast_snooping" in + write_one_line path (if value then "1" else "0") + with _ -> + warn "Could not %s IGMP-snooping on bridge %s" (if value then "enable" else "disable") bridge + let bridge_to_interfaces bridge = try Array.to_list (Sys.readdir (getpath bridge "brif")) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index bbc52caef..24098412a 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -502,6 +502,7 @@ module Bridge = struct | Bridge -> ignore (Brctl.create_bridge name); Brctl.set_forwarding_delay name 0; + Sysfs.set_multicast_snooping name false; Opt.iter (Ip.set_mac name) mac; match vlan with | None -> () From b3ffbc1ab82c8f84c6a8dd17f0201a8d761c8686 Mon Sep 17 00:00:00 2001 From: Si Beaumont Date: Wed, 16 Mar 2016 16:59:05 +0000 Subject: [PATCH 084/260] CP-15132: Legacy bringup script has moved out of init Signed-off-by: Si Beaumont --- networkd/network_server.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 24098412a..db71c6a22 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -30,7 +30,7 @@ let backend_kind = ref Openvswitch let legacy_management_interface_start () = try - ignore (call_script "/etc/init.d/management-interface" ["start"]); + ignore (call_script "/opt/xensource/libexec/legacy-management-interface" ["start"]); debug "Upgrade: brought up interfaces using the old script. Xapi will sync up soon." with e -> debug "Error while configuring the management interface using the old script: %s\n%s" From 858dbe667afa26338e9afd8e22287d3a823b613b Mon Sep 17 00:00:00 2001 From: Si Beaumont Date: Mon, 11 Apr 2016 14:05:48 +0100 Subject: [PATCH 085/260] Revert "CP-15132: Legacy bringup script has moved out of init" --- networkd/network_server.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index db71c6a22..24098412a 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -30,7 +30,7 @@ let backend_kind = ref Openvswitch let legacy_management_interface_start () = try - ignore (call_script "/opt/xensource/libexec/legacy-management-interface" ["start"]); + ignore (call_script "/etc/init.d/management-interface" ["start"]); debug "Upgrade: brought up interfaces using the old script. Xapi will sync up soon." with e -> debug "Error while configuring the management interface using the old script: %s\n%s" From f11fd4a735b2d807a25269c9fe91758c560e5e3c Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 12 Apr 2016 16:40:59 +0100 Subject: [PATCH 086/260] CA-206909: Write PID file after finishing startup activities Signed-off-by: Rob Hoes --- networkd/networkd.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/networkd/networkd.ml b/networkd/networkd.ml index d53ed6396..80d9bf439 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -94,15 +94,15 @@ let _ = ~rpc_fn:(Server.process ()) () in - Xcp_service.maybe_daemonize (); + Xcp_service.maybe_daemonize ~start_fn:(fun () -> + Debug.set_facility Syslog.Local5; - Debug.set_facility Syslog.Local5; + (* We should make the following configurable *) + Debug.disable "http"; - (* We should make the following configurable *) - Debug.disable "http"; - - handle_shutdown (); - Debug.with_thread_associated "main" start server; + handle_shutdown (); + Debug.with_thread_associated "main" start server + ) (); while true do Thread.delay 300.; From 49be6b0a221256e0b32f623d56cd32fff4d5b325 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Wed, 4 May 2016 16:10:39 +0100 Subject: [PATCH 087/260] CA-209399: Set mac-table-size to 10000 when creating bridges Signed-off-by: Jon Ludlam --- lib/network_utils.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index ebe4e8883..884c0d200 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -805,8 +805,10 @@ module Ovs = struct else [] in + let set_mac_table_size = ["--"; "set"; "bridge"; name; "other_config:mac-table-size=10000"] + in vsctl ~log:true (del_old_arg @ ["--"; "--may-exist"; "add-br"; name] @ - vlan_arg @ mac_arg @ fail_mode_arg @ disable_in_band_arg @ external_id_arg @ vif_arg) + vlan_arg @ mac_arg @ fail_mode_arg @ disable_in_band_arg @ external_id_arg @ vif_arg @ set_mac_table_size) let destroy_bridge name = vsctl ~log:true ["--"; "--if-exists"; "del-br"; name] From 278b2d007a6860bfd1722136912f37627151c780 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Thu, 5 May 2016 13:40:54 +0100 Subject: [PATCH 088/260] Make mac-table-size configurable Signed-off-by: Jon Ludlam --- lib/network_utils.ml | 3 ++- networkd/networkd.ml | 1 + 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 884c0d200..61bea5301 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -33,6 +33,7 @@ let modprobe = "/sbin/modprobe" let ethtool = ref "/sbin/ethtool" let bonding_dir = "/proc/net/bonding/" let fcoedriver = ref "/opt/xensource/libexec/fcoe_driver" +let mac_table_size = ref 10000 let call_script ?(log_successful_output=false) ?(timeout=Some 60.0) script args = try @@ -805,7 +806,7 @@ module Ovs = struct else [] in - let set_mac_table_size = ["--"; "set"; "bridge"; name; "other_config:mac-table-size=10000"] + let set_mac_table_size = ["--"; "set"; "bridge"; name; "other_config:mac-table-size=" ^ (string_of_int !mac_table_size)] in vsctl ~log:true (del_old_arg @ ["--"; "--may-exist"; "add-br"; name] @ vlan_arg @ mac_arg @ fail_mode_arg @ disable_in_band_arg @ external_id_arg @ vif_arg @ set_mac_table_size) diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 80d9bf439..da232dd27 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -51,6 +51,7 @@ let resources = [ let options = [ "monitor_blacklist", Arg.String (fun x -> Network_monitor_thread.monitor_blacklist := String.split ',' x), (fun () -> String.concat "," !Network_monitor_thread.monitor_blacklist), "List of prefixes of interface names that are not to be monitored"; + "mac-table-size", Arg.Set_int Network_utils.mac_table_size, (fun () -> string_of_int !Network_utils.mac_table_size), "Default value for the mac-table-size openvswitch parameter (see ovs-vswitchd.conf.db.5)"; ] let start server = From 186d5d856f1a0b93d834d75158494ad73f6af89a Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Mon, 9 May 2016 14:06:56 +0100 Subject: [PATCH 089/260] CA-210158: Only set mac-table-size on real (non-VLAN) bridges Signed-off-by: Rob Hoes --- lib/network_utils.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 61bea5301..21714945a 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -806,7 +806,11 @@ module Ovs = struct else [] in - let set_mac_table_size = ["--"; "set"; "bridge"; name; "other_config:mac-table-size=" ^ (string_of_int !mac_table_size)] + let set_mac_table_size = + if vlan = None then + ["--"; "set"; "bridge"; name; "other_config:mac-table-size=" ^ (string_of_int !mac_table_size)] + else + [] in vsctl ~log:true (del_old_arg @ ["--"; "--may-exist"; "add-br"; name] @ vlan_arg @ mac_arg @ fail_mode_arg @ disable_in_band_arg @ external_id_arg @ vif_arg @ set_mac_table_size) From 1694ddd5d9d6b2f3c008cc78ee26c26f248d18b6 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Wed, 4 May 2016 16:10:39 +0100 Subject: [PATCH 090/260] CA-209399: Set mac-table-size to 10000 when creating bridges Signed-off-by: Jon Ludlam --- lib/network_utils.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index ebe4e8883..884c0d200 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -805,8 +805,10 @@ module Ovs = struct else [] in + let set_mac_table_size = ["--"; "set"; "bridge"; name; "other_config:mac-table-size=10000"] + in vsctl ~log:true (del_old_arg @ ["--"; "--may-exist"; "add-br"; name] @ - vlan_arg @ mac_arg @ fail_mode_arg @ disable_in_band_arg @ external_id_arg @ vif_arg) + vlan_arg @ mac_arg @ fail_mode_arg @ disable_in_band_arg @ external_id_arg @ vif_arg @ set_mac_table_size) let destroy_bridge name = vsctl ~log:true ["--"; "--if-exists"; "del-br"; name] From e9865fdc226faf1e00e5cfeeec193d22b7a48925 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Thu, 5 May 2016 13:40:54 +0100 Subject: [PATCH 091/260] Make mac-table-size configurable Signed-off-by: Jon Ludlam --- lib/network_utils.ml | 3 ++- networkd/networkd.ml | 1 + 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 884c0d200..61bea5301 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -33,6 +33,7 @@ let modprobe = "/sbin/modprobe" let ethtool = ref "/sbin/ethtool" let bonding_dir = "/proc/net/bonding/" let fcoedriver = ref "/opt/xensource/libexec/fcoe_driver" +let mac_table_size = ref 10000 let call_script ?(log_successful_output=false) ?(timeout=Some 60.0) script args = try @@ -805,7 +806,7 @@ module Ovs = struct else [] in - let set_mac_table_size = ["--"; "set"; "bridge"; name; "other_config:mac-table-size=10000"] + let set_mac_table_size = ["--"; "set"; "bridge"; name; "other_config:mac-table-size=" ^ (string_of_int !mac_table_size)] in vsctl ~log:true (del_old_arg @ ["--"; "--may-exist"; "add-br"; name] @ vlan_arg @ mac_arg @ fail_mode_arg @ disable_in_band_arg @ external_id_arg @ vif_arg @ set_mac_table_size) diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 80d9bf439..da232dd27 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -51,6 +51,7 @@ let resources = [ let options = [ "monitor_blacklist", Arg.String (fun x -> Network_monitor_thread.monitor_blacklist := String.split ',' x), (fun () -> String.concat "," !Network_monitor_thread.monitor_blacklist), "List of prefixes of interface names that are not to be monitored"; + "mac-table-size", Arg.Set_int Network_utils.mac_table_size, (fun () -> string_of_int !Network_utils.mac_table_size), "Default value for the mac-table-size openvswitch parameter (see ovs-vswitchd.conf.db.5)"; ] let start server = From caa66852c462acda2d0e38676921ccde5b66a4fe Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Mon, 9 May 2016 14:06:56 +0100 Subject: [PATCH 092/260] CA-210158: Only set mac-table-size on real (non-VLAN) bridges Signed-off-by: Rob Hoes --- lib/network_utils.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 61bea5301..21714945a 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -806,7 +806,11 @@ module Ovs = struct else [] in - let set_mac_table_size = ["--"; "set"; "bridge"; name; "other_config:mac-table-size=" ^ (string_of_int !mac_table_size)] + let set_mac_table_size = + if vlan = None then + ["--"; "set"; "bridge"; name; "other_config:mac-table-size=" ^ (string_of_int !mac_table_size)] + else + [] in vsctl ~log:true (del_old_arg @ ["--"; "--may-exist"; "add-br"; name] @ vlan_arg @ mac_arg @ fail_mode_arg @ disable_in_band_arg @ external_id_arg @ vif_arg @ set_mac_table_size) From 99a057e53e201d92994cb133aa7f01fcd04755f0 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 13 May 2016 15:27:07 +0100 Subject: [PATCH 093/260] CA-210762: Linux bridge: Always update bond properties (#78) CA-210762: Linux bridge: Always update bond properties Bond properties such as the bond mode were not updated if the bond already existed. This caused XenAPI commands such as Bond.set_mode to have no immediate effect (changes would be implemented only after re-plugging or rebooting). Also make sure that bond-manipulation functions in Network_utils are idempotent, as the high-level function call is supposed to be idempotent. Signed-off-by: Rob Hoes --- lib/network_utils.ml | 127 +++++++++++++++++++++++++------------ networkd/network_server.ml | 25 ++++---- 2 files changed, 97 insertions(+), 55 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 21714945a..c4b8701b3 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -14,6 +14,7 @@ open Listext open Xstringext +open Pervasiveext open Fun open Network_interface @@ -208,11 +209,18 @@ info "Found at [ %s ]" (String.concat ", " (List.map string_of_int indices)); with e -> error "MTU size is not supported: %s" (string_of_int mtu) let link_set_up dev = - ignore (link_set dev ["up"]) + link_set dev ["up"] let link_set_down dev = if is_up dev then - ignore (link_set dev ["down"]) + link_set dev ["down"] + + let with_links_down devs f = + let up_links = List.filter (fun dev -> is_up dev) devs in + List.iter (fun dev -> link_set dev ["down"]) up_links; + finally + f + (fun () -> List.iter link_set_up up_links) let link ?(version=V46) dev attr = let v = string_of_version version in @@ -402,6 +410,77 @@ module Linux_bonding = struct end else error "Bond master %s does not exist; cannot destroy it" name + let get_bond_slaves master = + let path = Sysfs.getpath master "bonding/slaves" in + let slaves = Sysfs.read_one_line path in + if slaves = "" then + [] + else + String.split ' ' slaves + + let add_bond_slaves master slaves = + List.iter (fun slave -> + debug "Adding slave %s to bond %s" slave master; + try + Sysfs.write_one_line (Sysfs.getpath master "bonding/slaves") ("+" ^ slave) + with _ -> + error "Failed to add slave %s to bond %s" slave master + ) slaves + + let remove_bond_slaves master slaves = + List.iter (fun slave -> + debug "Removing slave %s from bond %s" slave master; + try + Sysfs.write_one_line (Sysfs.getpath master "bonding/slaves") ("-" ^ slave) + with _ -> + error "Failed to remove slave %s from bond %s" slave master + ) slaves + + let set_bond_slaves master slaves = + if is_bond_device master then + let current_slaves = get_bond_slaves master in + let slaves_to_remove = List.set_difference current_slaves slaves in + let slaves_to_add = List.set_difference slaves current_slaves in + Ip.with_links_down (slaves_to_add @ slaves_to_remove) (fun () -> + remove_bond_slaves master slaves_to_remove; + add_bond_slaves master slaves_to_add + ) + else + error "Bond %s does not exist; cannot set slaves" master + + let with_slaves_removed master f = + if is_bond_device master then + try + let slaves = get_bond_slaves master in + if slaves <> [] then begin + Ip.with_links_down slaves (fun () -> + remove_bond_slaves master slaves; + finally + f + (fun () -> add_bond_slaves master slaves) + ) + end + with _ -> + error "Failed to remove or re-add slaves from bond %s" master + else + error "Bond %s does not exist; cannot remove/add slaves" master + + let get_bond_master_of slave = + try + let master_symlink = Sysfs.getpath slave "master" in + let master_path = Unix.readlink master_symlink in + let slaves_path = Filename.concat master_symlink "bonding/slaves" in + Unix.access slaves_path [ Unix.F_OK ]; + Some (List.hd (List.rev (String.split '/' master_path))) + with _ -> None + + let get_bond_active_slave master = + try + Some (Sysfs.read_one_line (Sysfs.getpath master ("bonding/active_slave"))) + with _ -> + error "Failed to get active_slave of bond %s" master; + None + let known_props = ["mode"; "updelay"; "downdelay"; "miimon"; "use_carrier"] let get_bond_properties master = @@ -434,47 +513,13 @@ module Linux_bonding = struct with _ -> error "Failed to set property \"%s\" on bond %s" prop master in - Ip.link_set_down master; - List.iter set_prop props_to_update; - Ip.link_set_up master + Ip.with_links_down [master] (fun () -> + with_slaves_removed master (fun () -> + List.iter set_prop props_to_update + ) + ) end else error "Bond %s does not exist; cannot set properties" master - - let add_bond_slave master slave = - if is_bond_device master then - try - debug "Adding slave %s to bond %s" slave master; - Sysfs.write_one_line (Sysfs.getpath master "bonding/slaves") ("+" ^ slave) - with _ -> - error "Failed to add slave %s to bond %s" slave master - else - error "Bond %s does not exist; cannot add slave" master - - let remove_bond_slave master slave = - if is_bond_device master then - try - debug "Remove slave %s from bond %s" slave master; - Sysfs.write_one_line (Sysfs.getpath master "bonding/slaves") ("-" ^ slave) - with _ -> - error "Failed to remove slave %s from bond %s" slave master - else - error "Bond %s does not exist; cannot remove slave" master - - let get_bond_master_of slave = - try - let master_symlink = Sysfs.getpath slave "master" in - let master_path = Unix.readlink master_symlink in - let slaves_path = Filename.concat master_symlink "bonding/slaves" in - Unix.access slaves_path [ Unix.F_OK ]; - Some (List.hd (List.rev (String.split '/' master_path))) - with _ -> None - - let get_bond_active_slave master = - try - Some (Sysfs.read_one_line (Sysfs.getpath master ("bonding/active_slave"))) - with _ -> - error "Failed to get active_slave of bond %s" master; - None end module Dhclient = struct diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 24098412a..fbb47b272 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -727,20 +727,17 @@ module Bridge = struct if List.length interfaces = 1 then List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces else begin - if not (List.mem name (Sysfs.bridge_to_interfaces bridge)) then begin - Linux_bonding.add_bond_master name; - let bond_properties = - if List.mem_assoc "mode" bond_properties && List.assoc "mode" bond_properties = "lacp" then - List.replace_assoc "mode" "802.3ad" bond_properties - else bond_properties - in - Linux_bonding.set_bond_properties name bond_properties; - List.iter (fun name -> Interface.bring_down () dbg ~name) interfaces; - List.iter (Linux_bonding.add_bond_slave name) interfaces; - begin match bond_mac with - | Some mac -> Ip.set_mac name mac - | None -> warn "No MAC address specified for the bond" - end + Linux_bonding.add_bond_master name; + let bond_properties = + if List.mem_assoc "mode" bond_properties && List.assoc "mode" bond_properties = "lacp" then + List.replace_assoc "mode" "802.3ad" bond_properties + else bond_properties + in + Linux_bonding.set_bond_properties name bond_properties; + Linux_bonding.set_bond_slaves name interfaces; + begin match bond_mac with + | Some mac -> Ip.set_mac name mac + | None -> warn "No MAC address specified for the bond" end; Interface.bring_up () dbg ~name end; From 0cc305443332a1c87fd71e63446830890739b918 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Thu, 19 May 2016 23:33:25 +0100 Subject: [PATCH 094/260] CA-211448: When reading a line from sysfs, translate End_of_file to "" (#79) CA-211448: When reading a line from sysfs, translate End_of_file to "" Some sysfs files are "empty", for a good reason. Signed-off-by: Rob Hoes --- lib/network_utils.ml | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index c4b8701b3..cb21be745 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -77,12 +77,14 @@ module Sysfs = struct Printf.sprintf "/sys/class/net/%s/%s" dev attr let read_one_line file = - let inchan = open_in file in try - let result = input_line inchan in - close_in inchan; - result - with exn -> close_in inchan; raise (Read_error file) + let inchan = open_in file in + finally + (fun () -> input_line inchan) + (fun () -> close_in inchan) + with + | End_of_file -> "" + | exn -> error "%s" (Printexc.to_string exn); raise (Read_error file) let write_one_line file l = let outchan = open_out file in From a165af149ca4095ebba482938bcbe14982206c7c Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Fri, 13 May 2016 10:51:20 +0100 Subject: [PATCH 095/260] CP-17268 reformat _oasis to one BuildDepends per line This keeps long lists readable and allows to use comment individual entries. Signed-off-by: Christian Lindig --- _oasis | 40 +++++++++++++++++++++++++++++++++++----- setup.ml | 4 ++-- 2 files changed, 37 insertions(+), 7 deletions(-) diff --git a/_oasis b/_oasis index 5e7c0a3a1..7d77f3ae0 100644 --- a/_oasis +++ b/_oasis @@ -12,7 +12,14 @@ Library networklibs Path: lib Findlibname: network-libs Modules: Network_config, Network_utils - BuildDepends: forkexec, stdext, threads, rpclib, stdext, xcp-inventory, xcp.network + BuildDepends: + forkexec, + stdext, + threads, + rpclib, + stdext, + xcp-inventory, + xcp.network CSources: link_stubs.c, netdev.h CCOpt: -Wno-unused-function -g -ggdb @@ -22,7 +29,18 @@ Executable xcp_networkd MainIs: networkd.ml Custom: true Install: false - BuildDepends: threads, rpclib, rpclib.unix, forkexec, stdext, xcp-inventory, network-libs, xen-api-client, xcp, xcp.network, netlink + BuildDepends: + threads, + rpclib, + rpclib.unix, + forkexec, + stdext, + xcp-inventory, + network-libs, + xen-api-client, + xcp, + xcp.network, + netlink Executable networkd_db CompiledObject: best @@ -30,14 +48,21 @@ Executable networkd_db MainIs: networkd_db.ml Custom: true Install: false - BuildDepends: network-libs, stdext, threads, xcp.network + BuildDepends: + network-libs, + stdext, + threads, + xcp.network Executable network_test CompiledObject: best Path: test MainIs: network_test.ml Install: false - BuildDepends: stdext, oUnit, network-libs + BuildDepends: + stdext, + oUnit, + network-libs Test test_networkd Run$: flag(tests) @@ -48,5 +73,10 @@ Executable cli CompiledObject: best Path: cli MainIs: network_cli.ml - BuildDepends: cmdliner, stdext, network-libs, xcp, xcp.network + BuildDepends: + cmdliner, + stdext, + network-libs, + xcp, + xcp.network diff --git a/setup.ml b/setup.ml index 2e4d52e11..dea346575 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 60f46313d4d359dda4540e0275083b1c) *) +(* DO NOT EDIT (digest: 43a3d9947a3be0edd9199e92ca6632d9) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and @@ -7105,7 +7105,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; - oasis_digest = Some "\137l�\024�\b��\030\0115�\"\156�"; + oasis_digest = Some "G\254\016y\180\146\147*T \181\173\153\205\028\231"; oasis_exec = None; oasis_setup_args = []; setup_update = false From a62839c2e046068c73f944f29456e475c7a679a0 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Fri, 13 May 2016 13:02:48 +0100 Subject: [PATCH 096/260] CP-17268 First attempt of getting profiling to work Right now, programs don't seem to exit properly. Still investigating. Signed-off-by: Christian Lindig --- _oasis | 4 ++++ _tags | 10 +++++++++- cli/network_cli.ml | 26 ++++++++++++++++++++++++++ networkd/networkd.ml | 28 ++++++++++++++++++++++++++++ networkd_db/networkd_db.ml | 35 +++++++++++++++++++++++++++++++++++ setup.ml | 10 +++++++--- test/network_test.ml | 30 +++++++++++++++++++++++++++++- 7 files changed, 138 insertions(+), 5 deletions(-) diff --git a/_oasis b/_oasis index 7d77f3ae0..e93db7e24 100644 --- a/_oasis +++ b/_oasis @@ -30,6 +30,7 @@ Executable xcp_networkd Custom: true Install: false BuildDepends: + bisect_ppx, # coverage profiling threads, rpclib, rpclib.unix, @@ -49,6 +50,7 @@ Executable networkd_db Custom: true Install: false BuildDepends: + bisect_ppx, # coverage profiling network-libs, stdext, threads, @@ -60,6 +62,7 @@ Executable network_test MainIs: network_test.ml Install: false BuildDepends: + bisect_ppx, # coverage profiling stdext, oUnit, network-libs @@ -74,6 +77,7 @@ Executable cli Path: cli MainIs: network_cli.ml BuildDepends: + bisect_ppx, cmdliner, stdext, network-libs, diff --git a/_tags b/_tags index e444bba7c..4f9b4c2ca 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 24d382d63f193063ab9b3c2a825d1463) +# DO NOT EDIT (digest: abe036828d7944bed4687c8b446ac730) # 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 @@ -32,6 +32,7 @@ true: annot, bin_annot "lib/link_stubs.c": pkg_xcp-inventory "lib/link_stubs.c": pkg_xcp.network # Executable xcp_networkd +: pkg_bisect_ppx : pkg_forkexec : pkg_netlink : pkg_rpclib @@ -43,6 +44,7 @@ true: annot, bin_annot : pkg_xcp.network : pkg_xen-api-client : use_networklibs +: pkg_bisect_ppx : pkg_forkexec : pkg_netlink : pkg_rpclib @@ -56,6 +58,7 @@ true: annot, bin_annot : use_networklibs : custom # Executable networkd_db +: pkg_bisect_ppx : pkg_forkexec : pkg_rpclib : pkg_stdext @@ -63,6 +66,7 @@ true: annot, bin_annot : pkg_xcp-inventory : pkg_xcp.network : use_networklibs +: pkg_bisect_ppx : pkg_forkexec : pkg_rpclib : pkg_stdext @@ -72,6 +76,7 @@ true: annot, bin_annot : use_networklibs : custom # Executable network_test +: pkg_bisect_ppx : pkg_forkexec : pkg_oUnit : pkg_rpclib @@ -80,6 +85,7 @@ true: annot, bin_annot : pkg_xcp-inventory : pkg_xcp.network : use_networklibs +: pkg_bisect_ppx : pkg_forkexec : pkg_oUnit : pkg_rpclib @@ -89,6 +95,7 @@ true: annot, bin_annot : pkg_xcp.network : use_networklibs # Executable cli +: pkg_bisect_ppx : pkg_cmdliner : pkg_forkexec : pkg_rpclib @@ -98,6 +105,7 @@ true: annot, bin_annot : pkg_xcp-inventory : pkg_xcp.network : use_networklibs +: pkg_bisect_ppx : pkg_cmdliner : pkg_forkexec : pkg_rpclib diff --git a/cli/network_cli.ml b/cli/network_cli.ml index b7119b642..996c3acdc 100644 --- a/cli/network_cli.ml +++ b/cli/network_cli.ml @@ -349,6 +349,32 @@ let cmds = [ list_br_cmd; config_cmd] +(** sets env variable for log files *) +let setup_coverage_profiling name = + let (//) = Filename.concat in + let tmpdir = + let getenv n = try Sys.getenv n with Not_found -> "" in + let dirs = + [ getenv "TMP" + ; getenv "TEMP" + ; "/tmp" + ; "/usr/tmp" + ; "/var/tmp" + ] in + let is_dir = function + | "" -> false + | path -> try Sys.is_directory path with Sys_error _ -> false + in try + List.find is_dir dirs + with + Not_found -> failwith ("can't find temp directory "^__LOC__); exit 1 + in try + ignore (Sys.getenv "BISECT_FILE") + with Not_found -> + Unix.putenv "BISECT_FILE" (tmpdir // Printf.sprintf "bisect-%s" name) + + let _ = + setup_coverage_profiling Sys.argv.(0); match Term.eval_choice default_cmd cmds with | `Error _ -> exit 1 | _ -> exit 0 diff --git a/networkd/networkd.ml b/networkd/networkd.ml index da232dd27..6430c1ca6 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -54,6 +54,32 @@ let options = [ "mac-table-size", Arg.Set_int Network_utils.mac_table_size, (fun () -> string_of_int !Network_utils.mac_table_size), "Default value for the mac-table-size openvswitch parameter (see ovs-vswitchd.conf.db.5)"; ] +(** This just sets up an environment variable and has no effect unless + * we are compiling for profiling *) + +let setup_coverage_profiling name = + let (//) = Filename.concat in + let tmpdir = + let getenv n = try Sys.getenv n with Not_found -> "" in + let dirs = + [ getenv "TMP" + ; getenv "TEMP" + ; "/tmp" + ; "/usr/tmp" + ; "/var/tmp" + ] in + let is_dir = function + | "" -> false + | path -> try Sys.is_directory path with Sys_error _ -> false + in try + List.find is_dir dirs + with + Not_found -> D.error "can't find temp directory %s" __LOC__; exit 1 + in try + ignore (Sys.getenv "BISECT_FILE") + with Not_found -> + Unix.putenv "BISECT_FILE" (tmpdir // Printf.sprintf "bisect-%s" name) + let start server = Network_monitor_thread.start (); Network_server.on_startup (); @@ -89,6 +115,8 @@ let _ = exit 1 end; + setup_coverage_profiling Sys.argv.(0); + let server = Xcp_service.make ~path:!Network_interface.default_path ~queue_name:!Network_interface.queue_name diff --git a/networkd_db/networkd_db.ml b/networkd_db/networkd_db.ml index eb8ef08fa..fddab1cc1 100644 --- a/networkd_db/networkd_db.ml +++ b/networkd_db/networkd_db.ml @@ -17,6 +17,40 @@ open Network_interface let name = "networkd_db" +(* catch signals for clean shutdown *) +let stop signal = + exit 0 + +let handle_shutdown () = + Sys.set_signal Sys.sigterm (Sys.Signal_handle stop); + Sys.set_signal Sys.sigint (Sys.Signal_handle stop); + Sys.set_signal Sys.sigpipe Sys.Signal_ignore + +(** set env variable for profiling *) +let setup_coverage_profiling name = + let (//) = Filename.concat in + let tmpdir = + let getenv n = try Sys.getenv n with Not_found -> "" in + let dirs = + [ getenv "TMP" + ; getenv "TEMP" + ; "/tmp" + ; "/usr/tmp" + ; "/var/tmp" + ] in + let is_dir = function + | "" -> false + | path -> try Sys.is_directory path with Sys_error _ -> false + in try + List.find is_dir dirs + with + Not_found -> failwith ("can't find temp directory "^__LOC__); exit 1 + in try + ignore (Sys.getenv "BISECT_FILE") + with Not_found -> + Unix.putenv "BISECT_FILE" (tmpdir // Printf.sprintf "bisect-%s" name) + + let _ = let bridge = ref "" in let iface = ref "" in @@ -29,6 +63,7 @@ let _ = (Printf.sprintf "Usage: %s [-bridge | -iface ]" name); try + setup_coverage_profiling Sys.argv.(0); let config = Network_config.read_config () in if !bridge <> "" then if List.mem_assoc !bridge config.bridge_config then begin diff --git a/setup.ml b/setup.ml index dea346575..e55297be4 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 43a3d9947a3be0edd9199e92ca6632d9) *) +(* DO NOT EDIT (digest: 1b9e007061b02a214a07924604b691b9) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6960,6 +6960,7 @@ let setup_t = bs_compiled_object = Best; bs_build_depends = [ + FindlibPackage ("bisect_ppx", None); FindlibPackage ("threads", None); FindlibPackage ("rpclib", None); FindlibPackage ("rpclib.unix", None); @@ -6996,6 +6997,7 @@ let setup_t = bs_compiled_object = Best; bs_build_depends = [ + FindlibPackage ("bisect_ppx", None); InternalLibrary "networklibs"; FindlibPackage ("stdext", None); FindlibPackage ("threads", None); @@ -7025,6 +7027,7 @@ let setup_t = bs_compiled_object = Best; bs_build_depends = [ + FindlibPackage ("bisect_ppx", None); FindlibPackage ("stdext", None); FindlibPackage ("oUnit", None); InternalLibrary "networklibs" @@ -7080,6 +7083,7 @@ let setup_t = bs_compiled_object = Best; bs_build_depends = [ + FindlibPackage ("bisect_ppx", None); FindlibPackage ("cmdliner", None); FindlibPackage ("stdext", None); InternalLibrary "networklibs"; @@ -7105,7 +7109,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; - oasis_digest = Some "G\254\016y\180\146\147*T \181\173\153\205\028\231"; + oasis_digest = Some "\187\163\183`\166U\204\190\b\188[\214\226x\014\172"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7113,6 +7117,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7117 "setup.ml" +# 7121 "setup.ml" (* OASIS_STOP *) let () = setup ();; diff --git a/test/network_test.ml b/test/network_test.ml index e868f6c3a..676250875 100644 --- a/test/network_test.ml +++ b/test/network_test.ml @@ -14,10 +14,38 @@ open OUnit +(** sets env variable for log files *) +let setup_coverage_profiling name = + let (//) = Filename.concat in + let tmpdir = + let getenv n = try Sys.getenv n with Not_found -> "" in + let dirs = + [ getenv "TMP" + ; getenv "TEMP" + ; "/tmp" + ; "/usr/tmp" + ; "/var/tmp" + ] in + let is_dir = function + | "" -> false + | path -> try Sys.is_directory path with Sys_error _ -> false + in try + List.find is_dir dirs + with + Not_found -> failwith ("can't find temp directory "^__LOC__); exit 1 + in try + ignore (Sys.getenv "BISECT_FILE") + with Not_found -> + Unix.putenv "BISECT_FILE" (tmpdir // Printf.sprintf "bisect-%s" name) + + + let base_suite = "base_suite" >::: [ Network_test_lacp_properties.suite; ] -let _ = run_test_tt_main base_suite +let _ = + setup_coverage_profiling Sys.argv.(0); + run_test_tt_main base_suite From d42429dfea17dc62ccb11ddcd646c629b40f8925 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Fri, 13 May 2016 13:51:17 +0100 Subject: [PATCH 097/260] CP-17268 don't use Sys.argv.(0) to set up name for bisect log I've seen programs hang when using Sys.argv.(0) and suspect that the array is empty some times. Maybe some argument parser is modifying it? Signed-off-by: Christian Lindig --- _oasis | 3 ++- _tags | 4 +++- cli/network_cli.ml | 6 +++--- lib/META | 5 +++-- networkd/networkd.ml | 5 ++--- networkd_db/networkd_db.ml | 4 ++-- setup.ml | 7 ++++--- test/network_test.ml | 6 +++--- 8 files changed, 22 insertions(+), 18 deletions(-) diff --git a/_oasis b/_oasis index e93db7e24..26828cc0b 100644 --- a/_oasis +++ b/_oasis @@ -13,6 +13,7 @@ Library networklibs Findlibname: network-libs Modules: Network_config, Network_utils BuildDepends: + bisect_ppx, # coverage profiling forkexec, stdext, threads, @@ -77,7 +78,7 @@ Executable cli Path: cli MainIs: network_cli.ml BuildDepends: - bisect_ppx, + bisect_ppx, # coverage profiling cmdliner, stdext, network-libs, diff --git a/_tags b/_tags index 4f9b4c2ca..86c16bbcd 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: abe036828d7944bed4687c8b446ac730) +# DO NOT EDIT (digest: 995971be38af33c135997a642a4e0bf4) # 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,12 +19,14 @@ true: annot, bin_annot : oasis_library_networklibs_ccopt "lib/link_stubs.c": oasis_library_networklibs_ccopt : use_libnetworklibs_stubs +: pkg_bisect_ppx : pkg_forkexec : pkg_rpclib : pkg_stdext : pkg_threads : pkg_xcp-inventory : pkg_xcp.network +"lib/link_stubs.c": pkg_bisect_ppx "lib/link_stubs.c": pkg_forkexec "lib/link_stubs.c": pkg_rpclib "lib/link_stubs.c": pkg_stdext diff --git a/cli/network_cli.ml b/cli/network_cli.ml index 996c3acdc..22dc8c287 100644 --- a/cli/network_cli.ml +++ b/cli/network_cli.ml @@ -367,14 +367,14 @@ let setup_coverage_profiling name = in try List.find is_dir dirs with - Not_found -> failwith ("can't find temp directory "^__LOC__); exit 1 + Not_found -> failwith ("can't find temp directory "^__LOC__) in try ignore (Sys.getenv "BISECT_FILE") with Not_found -> - Unix.putenv "BISECT_FILE" (tmpdir // Printf.sprintf "bisect-%s" name) + Unix.putenv "BISECT_FILE" (tmpdir // Printf.sprintf "bisect-%s-" name) let _ = - setup_coverage_profiling Sys.argv.(0); + setup_coverage_profiling "network_cli"; match Term.eval_choice default_cmd cmds with | `Error _ -> exit 1 | _ -> exit 0 diff --git a/lib/META b/lib/META index d698906fb..71bc6172a 100644 --- a/lib/META +++ b/lib/META @@ -1,8 +1,9 @@ # OASIS_START -# DO NOT EDIT (digest: de99a9d89799ce8282274091a7a1fc5b) +# DO NOT EDIT (digest: 35cbba17e3743e686fa9c799c2fb117d) version = "0.10.0" description = "XCP Network Daemon" -requires = "forkexec stdext threads rpclib stdext xcp-inventory xcp.network" +requires = +"bisect_ppx forkexec stdext threads rpclib stdext xcp-inventory xcp.network" archive(byte) = "networklibs.cma" archive(byte, plugin) = "networklibs.cma" archive(native) = "networklibs.cmxa" diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 6430c1ca6..16a4d2371 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -78,7 +78,7 @@ let setup_coverage_profiling name = in try ignore (Sys.getenv "BISECT_FILE") with Not_found -> - Unix.putenv "BISECT_FILE" (tmpdir // Printf.sprintf "bisect-%s" name) + Unix.putenv "BISECT_FILE" (tmpdir // Printf.sprintf "bisect-%s-" name) let start server = Network_monitor_thread.start (); @@ -105,6 +105,7 @@ let doc = String.concat "\n" [ ] let _ = + setup_coverage_profiling "networkd"; begin match Xcp_service.configure2 ~name:Sys.argv.(0) ~version:Version.version @@ -115,8 +116,6 @@ let _ = exit 1 end; - setup_coverage_profiling Sys.argv.(0); - let server = Xcp_service.make ~path:!Network_interface.default_path ~queue_name:!Network_interface.queue_name diff --git a/networkd_db/networkd_db.ml b/networkd_db/networkd_db.ml index fddab1cc1..c055a7d08 100644 --- a/networkd_db/networkd_db.ml +++ b/networkd_db/networkd_db.ml @@ -48,7 +48,7 @@ let setup_coverage_profiling name = in try ignore (Sys.getenv "BISECT_FILE") with Not_found -> - Unix.putenv "BISECT_FILE" (tmpdir // Printf.sprintf "bisect-%s" name) + Unix.putenv "BISECT_FILE" (tmpdir // Printf.sprintf "bisect-%s-" name) let _ = @@ -63,7 +63,7 @@ let _ = (Printf.sprintf "Usage: %s [-bridge | -iface ]" name); try - setup_coverage_profiling Sys.argv.(0); + setup_coverage_profiling "network_db"; let config = Network_config.read_config () in if !bridge <> "" then if List.mem_assoc !bridge config.bridge_config then begin diff --git a/setup.ml b/setup.ml index e55297be4..3340be912 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 1b9e007061b02a214a07924604b691b9) *) +(* DO NOT EDIT (digest: 672223564f730945b8c4272fe11d5b59) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6917,6 +6917,7 @@ let setup_t = bs_compiled_object = Best; bs_build_depends = [ + FindlibPackage ("bisect_ppx", None); FindlibPackage ("forkexec", None); FindlibPackage ("stdext", None); FindlibPackage ("threads", None); @@ -7109,7 +7110,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; - oasis_digest = Some "\187\163\183`\166U\204\190\b\188[\214\226x\014\172"; + oasis_digest = Some "~\167\031\011)c\128$N\214)\208D\172\230\188"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7117,6 +7118,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7121 "setup.ml" +# 7122 "setup.ml" (* OASIS_STOP *) let () = setup ();; diff --git a/test/network_test.ml b/test/network_test.ml index 676250875..feecceae3 100644 --- a/test/network_test.ml +++ b/test/network_test.ml @@ -32,11 +32,11 @@ let setup_coverage_profiling name = in try List.find is_dir dirs with - Not_found -> failwith ("can't find temp directory "^__LOC__); exit 1 + Not_found -> failwith ("can't find temp directory "^__LOC__) in try ignore (Sys.getenv "BISECT_FILE") with Not_found -> - Unix.putenv "BISECT_FILE" (tmpdir // Printf.sprintf "bisect-%s" name) + Unix.putenv "BISECT_FILE" (tmpdir // Printf.sprintf "bisect-%s-" name) @@ -47,5 +47,5 @@ let base_suite = ] let _ = - setup_coverage_profiling Sys.argv.(0); + setup_coverage_profiling "network_test"; run_test_tt_main base_suite From 683d976c681858b558890544baa2df2fe9eeb5af Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Fri, 13 May 2016 15:05:51 +0100 Subject: [PATCH 098/260] CP-17268 put coverage setup code in (small) common lib in profiling/ The code to set up profiling is used from several binaries. It does not harm to compile it into a non-profiled binary. Signed-off-by: Christian Lindig --- _oasis | 15 ++++++++++---- _tags | 12 +++++++++++- myocamlbuild.ml | 15 +++++++------- networkd/networkd.ml | 29 ++------------------------- networkd_db/networkd_db.ml | 27 +------------------------ profiling/META | 11 +++++++++++ profiling/coverage.ml | 35 +++++++++++++++++++++++++++++++++ profiling/coverage.mldylib | 4 ++++ profiling/coverage.mli | 7 +++++++ profiling/coverage.mllib | 4 ++++ setup.ml | 40 +++++++++++++++++++++++++++++++++++--- test/network_test.ml | 28 +------------------------- 12 files changed, 132 insertions(+), 95 deletions(-) create mode 100644 profiling/META create mode 100644 profiling/coverage.ml create mode 100644 profiling/coverage.mldylib create mode 100644 profiling/coverage.mli create mode 100644 profiling/coverage.mllib diff --git a/_oasis b/_oasis index 26828cc0b..747f663be 100644 --- a/_oasis +++ b/_oasis @@ -7,6 +7,13 @@ License: LGPL-2.1 with OCaml linking exception Plugins: META (0.2) BuildTools: ocamlbuild +Library coverage + CompiledObject: best + Path: profiling + Findlibname: coverage + Modules: Coverage + BuildDepends: + Library networklibs CompiledObject: best Path: lib @@ -31,7 +38,7 @@ Executable xcp_networkd Custom: true Install: false BuildDepends: - bisect_ppx, # coverage profiling + coverage, bisect_ppx, # coverage profiling threads, rpclib, rpclib.unix, @@ -51,7 +58,7 @@ Executable networkd_db Custom: true Install: false BuildDepends: - bisect_ppx, # coverage profiling + coverage, bisect_ppx, # coverage profiling network-libs, stdext, threads, @@ -63,7 +70,7 @@ Executable network_test MainIs: network_test.ml Install: false BuildDepends: - bisect_ppx, # coverage profiling + coverage, bisect_ppx, # coverage profiling stdext, oUnit, network-libs @@ -78,7 +85,7 @@ Executable cli Path: cli MainIs: network_cli.ml BuildDepends: - bisect_ppx, # coverage profiling + coverage, bisect_ppx, # coverage profiling cmdliner, stdext, network-libs, diff --git a/_tags b/_tags index 86c16bbcd..d0b19bee2 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 995971be38af33c135997a642a4e0bf4) +# DO NOT EDIT (digest: b74bb634db47e28ee82b535b78c98e87) # 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 @@ -14,6 +14,8 @@ true: annot, bin_annot ".git": not_hygienic "_darcs": -traverse "_darcs": not_hygienic +# Library coverage +"profiling/coverage.cmxs": use_coverage # Library networklibs "lib/networklibs.cmxs": use_networklibs : oasis_library_networklibs_ccopt @@ -45,6 +47,7 @@ true: annot, bin_annot : pkg_xcp-inventory : pkg_xcp.network : pkg_xen-api-client +: use_coverage : use_networklibs : pkg_bisect_ppx : pkg_forkexec @@ -57,6 +60,7 @@ true: annot, bin_annot : pkg_xcp-inventory : pkg_xcp.network : pkg_xen-api-client +: use_coverage : use_networklibs : custom # Executable networkd_db @@ -67,6 +71,7 @@ true: annot, bin_annot : pkg_threads : pkg_xcp-inventory : pkg_xcp.network +: use_coverage : use_networklibs : pkg_bisect_ppx : pkg_forkexec @@ -75,6 +80,7 @@ true: annot, bin_annot : pkg_threads : pkg_xcp-inventory : pkg_xcp.network +: use_coverage : use_networklibs : custom # Executable network_test @@ -86,6 +92,7 @@ true: annot, bin_annot : pkg_threads : pkg_xcp-inventory : pkg_xcp.network +: use_coverage : use_networklibs : pkg_bisect_ppx : pkg_forkexec @@ -95,6 +102,7 @@ true: annot, bin_annot : pkg_threads : pkg_xcp-inventory : pkg_xcp.network +: use_coverage : use_networklibs # Executable cli : pkg_bisect_ppx @@ -106,6 +114,7 @@ true: annot, bin_annot : pkg_xcp : pkg_xcp-inventory : pkg_xcp.network +: use_coverage : use_networklibs : pkg_bisect_ppx : pkg_cmdliner @@ -116,6 +125,7 @@ true: annot, bin_annot : pkg_xcp : pkg_xcp-inventory : pkg_xcp.network +: use_coverage : use_networklibs # OASIS_STOP diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 70c058beb..166a70b1a 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 4ff56aec2dfea165b1692e299cedba7e) *) +(* DO NOT EDIT (digest: 14ff25fbda4435a4a93036984753949e) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) @@ -607,7 +607,8 @@ end open Ocamlbuild_plugin;; let package_default = { - MyOCamlbuildBase.lib_ocaml = [("networklibs", ["lib"], [])]; + MyOCamlbuildBase.lib_ocaml = + [("coverage", ["profiling"], []); ("networklibs", ["lib"], [])]; lib_c = [("networklibs", "lib", ["lib/netdev.h"])]; flags = [ @@ -627,10 +628,10 @@ let package_default = ]; includes = [ - ("test", ["lib"]); - ("networkd_db", ["lib"]); - ("networkd", ["lib"]); - ("cli", ["lib"]) + ("test", ["lib"; "profiling"]); + ("networkd_db", ["lib"; "profiling"]); + ("networkd", ["lib"; "profiling"]); + ("cli", ["lib"; "profiling"]) ] } ;; @@ -639,6 +640,6 @@ let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; -# 643 "myocamlbuild.ml" +# 644 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 16a4d2371..8a9177101 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -54,32 +54,7 @@ let options = [ "mac-table-size", Arg.Set_int Network_utils.mac_table_size, (fun () -> string_of_int !Network_utils.mac_table_size), "Default value for the mac-table-size openvswitch parameter (see ovs-vswitchd.conf.db.5)"; ] -(** This just sets up an environment variable and has no effect unless - * we are compiling for profiling *) - -let setup_coverage_profiling name = - let (//) = Filename.concat in - let tmpdir = - let getenv n = try Sys.getenv n with Not_found -> "" in - let dirs = - [ getenv "TMP" - ; getenv "TEMP" - ; "/tmp" - ; "/usr/tmp" - ; "/var/tmp" - ] in - let is_dir = function - | "" -> false - | path -> try Sys.is_directory path with Sys_error _ -> false - in try - List.find is_dir dirs - with - Not_found -> D.error "can't find temp directory %s" __LOC__; exit 1 - in try - ignore (Sys.getenv "BISECT_FILE") - with Not_found -> - Unix.putenv "BISECT_FILE" (tmpdir // Printf.sprintf "bisect-%s-" name) - + let start server = Network_monitor_thread.start (); Network_server.on_startup (); @@ -105,7 +80,7 @@ let doc = String.concat "\n" [ ] let _ = - setup_coverage_profiling "networkd"; + Coverage.init "networkd"; begin match Xcp_service.configure2 ~name:Sys.argv.(0) ~version:Version.version diff --git a/networkd_db/networkd_db.ml b/networkd_db/networkd_db.ml index c055a7d08..c15c7560f 100644 --- a/networkd_db/networkd_db.ml +++ b/networkd_db/networkd_db.ml @@ -26,31 +26,6 @@ let handle_shutdown () = Sys.set_signal Sys.sigint (Sys.Signal_handle stop); Sys.set_signal Sys.sigpipe Sys.Signal_ignore -(** set env variable for profiling *) -let setup_coverage_profiling name = - let (//) = Filename.concat in - let tmpdir = - let getenv n = try Sys.getenv n with Not_found -> "" in - let dirs = - [ getenv "TMP" - ; getenv "TEMP" - ; "/tmp" - ; "/usr/tmp" - ; "/var/tmp" - ] in - let is_dir = function - | "" -> false - | path -> try Sys.is_directory path with Sys_error _ -> false - in try - List.find is_dir dirs - with - Not_found -> failwith ("can't find temp directory "^__LOC__); exit 1 - in try - ignore (Sys.getenv "BISECT_FILE") - with Not_found -> - Unix.putenv "BISECT_FILE" (tmpdir // Printf.sprintf "bisect-%s-" name) - - let _ = let bridge = ref "" in let iface = ref "" in @@ -63,7 +38,7 @@ let _ = (Printf.sprintf "Usage: %s [-bridge | -iface ]" name); try - setup_coverage_profiling "network_db"; + Coverage.init "network_db"; let config = Network_config.read_config () in if !bridge <> "" then if List.mem_assoc !bridge config.bridge_config then begin diff --git a/profiling/META b/profiling/META new file mode 100644 index 000000000..ee3c14730 --- /dev/null +++ b/profiling/META @@ -0,0 +1,11 @@ +# OASIS_START +# DO NOT EDIT (digest: 6e7f6cff169a3b5c960903046d1c6a00) +version = "0.10.0" +description = "XCP Network Daemon" +archive(byte) = "coverage.cma" +archive(byte, plugin) = "coverage.cma" +archive(native) = "coverage.cmxa" +archive(native, plugin) = "coverage.cmxs" +exists_if = "coverage.cma" +# OASIS_STOP + diff --git a/profiling/coverage.ml b/profiling/coverage.ml new file mode 100644 index 000000000..adc136a55 --- /dev/null +++ b/profiling/coverage.ml @@ -0,0 +1,35 @@ + +(** This module sets up the env variable for bisect_ppx which describes + * where log files are writte + *) + +let (//) = Filename.concat + +let is_dir = function + | "" -> false + | path -> try Sys.is_directory path with Sys_error _ -> false + +(* [tmpdir] points to a directory for temporary files *) +let tmpdir = + let getenv n = try Sys.getenv n with Not_found -> "" in + let dirs = + [ getenv "TMP" + ; getenv "TEMP" + ; "/tmp" + ; "/usr/tmp" + ; "/var/tmp" + ] in + try + List.find is_dir dirs + with + Not_found -> failwith "can't find temp directory "^__LOC__ + +(** [init name] sets up coverage profiling for binary [name]. You could + * use [Sys.argv.(0) for name + *) +let init name = + try + ignore (Sys.getenv "BISECT_FILE") + with Not_found -> + Unix.putenv "BISECT_FILE" (tmpdir // Printf.sprintf "bisect-%s-" name) + diff --git a/profiling/coverage.mldylib b/profiling/coverage.mldylib new file mode 100644 index 000000000..2c6e555c2 --- /dev/null +++ b/profiling/coverage.mldylib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 9841bdc50c4226cb6ec5db76494249e6) +Coverage +# OASIS_STOP diff --git a/profiling/coverage.mli b/profiling/coverage.mli new file mode 100644 index 000000000..f9a84b34e --- /dev/null +++ b/profiling/coverage.mli @@ -0,0 +1,7 @@ + + +(** [init name] sets up coverage profiling for binary [name]. You could + * use [Sys.argv.(0) for name + *) + +val init: string -> unit diff --git a/profiling/coverage.mllib b/profiling/coverage.mllib new file mode 100644 index 000000000..2c6e555c2 --- /dev/null +++ b/profiling/coverage.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 9841bdc50c4226cb6ec5db76494249e6) +Coverage +# OASIS_STOP diff --git a/setup.ml b/setup.ml index 3340be912..e2c079859 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 672223564f730945b8c4272fe11d5b59) *) +(* DO NOT EDIT (digest: 8b15e1347b9a64456a33d736cbd939f3) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6904,6 +6904,36 @@ let setup_t = files_ab = []; sections = [ + Library + ({ + cs_name = "coverage"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "profiling"; + bs_compiled_object = Best; + bs_build_depends = []; + 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, [])] + }, + { + lib_modules = ["Coverage"]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = None; + lib_findlib_name = Some "coverage"; + lib_findlib_containers = [] + }); Library ({ cs_name = "networklibs"; @@ -6961,6 +6991,7 @@ let setup_t = bs_compiled_object = Best; bs_build_depends = [ + InternalLibrary "coverage"; FindlibPackage ("bisect_ppx", None); FindlibPackage ("threads", None); FindlibPackage ("rpclib", None); @@ -6998,6 +7029,7 @@ let setup_t = bs_compiled_object = Best; bs_build_depends = [ + InternalLibrary "coverage"; FindlibPackage ("bisect_ppx", None); InternalLibrary "networklibs"; FindlibPackage ("stdext", None); @@ -7028,6 +7060,7 @@ let setup_t = bs_compiled_object = Best; bs_build_depends = [ + InternalLibrary "coverage"; FindlibPackage ("bisect_ppx", None); FindlibPackage ("stdext", None); FindlibPackage ("oUnit", None); @@ -7084,6 +7117,7 @@ let setup_t = bs_compiled_object = Best; bs_build_depends = [ + InternalLibrary "coverage"; FindlibPackage ("bisect_ppx", None); FindlibPackage ("cmdliner", None); FindlibPackage ("stdext", None); @@ -7110,7 +7144,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; - oasis_digest = Some "~\167\031\011)c\128$N\214)\208D\172\230\188"; + oasis_digest = Some "\196\216\142i\251!\164t;\014\225\208\002b@n"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7118,6 +7152,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7122 "setup.ml" +# 7156 "setup.ml" (* OASIS_STOP *) let () = setup ();; diff --git a/test/network_test.ml b/test/network_test.ml index feecceae3..39349c20d 100644 --- a/test/network_test.ml +++ b/test/network_test.ml @@ -14,32 +14,6 @@ open OUnit -(** sets env variable for log files *) -let setup_coverage_profiling name = - let (//) = Filename.concat in - let tmpdir = - let getenv n = try Sys.getenv n with Not_found -> "" in - let dirs = - [ getenv "TMP" - ; getenv "TEMP" - ; "/tmp" - ; "/usr/tmp" - ; "/var/tmp" - ] in - let is_dir = function - | "" -> false - | path -> try Sys.is_directory path with Sys_error _ -> false - in try - List.find is_dir dirs - with - Not_found -> failwith ("can't find temp directory "^__LOC__) - in try - ignore (Sys.getenv "BISECT_FILE") - with Not_found -> - Unix.putenv "BISECT_FILE" (tmpdir // Printf.sprintf "bisect-%s-" name) - - - let base_suite = "base_suite" >::: [ @@ -47,5 +21,5 @@ let base_suite = ] let _ = - setup_coverage_profiling "network_test"; + Coverage.init "network_test"; run_test_tt_main base_suite From fe5249992e2bccc6210552b639b98ec2366264cd Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Fri, 13 May 2016 15:39:36 +0100 Subject: [PATCH 099/260] CP-17268 network_cli now uses Coverage.init(), too Signed-off-by: Christian Lindig --- cli/network_cli.ml | 27 +-------------------------- 1 file changed, 1 insertion(+), 26 deletions(-) diff --git a/cli/network_cli.ml b/cli/network_cli.ml index 22dc8c287..63578dd62 100644 --- a/cli/network_cli.ml +++ b/cli/network_cli.ml @@ -349,32 +349,7 @@ let cmds = [ list_br_cmd; config_cmd] -(** sets env variable for log files *) -let setup_coverage_profiling name = - let (//) = Filename.concat in - let tmpdir = - let getenv n = try Sys.getenv n with Not_found -> "" in - let dirs = - [ getenv "TMP" - ; getenv "TEMP" - ; "/tmp" - ; "/usr/tmp" - ; "/var/tmp" - ] in - let is_dir = function - | "" -> false - | path -> try Sys.is_directory path with Sys_error _ -> false - in try - List.find is_dir dirs - with - Not_found -> failwith ("can't find temp directory "^__LOC__) - in try - ignore (Sys.getenv "BISECT_FILE") - with Not_found -> - Unix.putenv "BISECT_FILE" (tmpdir // Printf.sprintf "bisect-%s-" name) - - let _ = - setup_coverage_profiling "network_cli"; + Coverage.init "network_cli"; match Term.eval_choice default_cmd cmds with | `Error _ -> exit 1 | _ -> exit 0 From fa80973ab0a86b171fefa7e5a7e1c54d079083c1 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Mon, 16 May 2016 11:33:30 +0100 Subject: [PATCH 100/260] CP-17268 integrate coverage profiling into build setup: make coverage This commit should make coverage profiling compatible with the main branch where we usually not build for coverage profiling. To set up a build for coverage, do: make coverage make This is undone by make oncover See COVERAGE.md for details. Signed-off-by: Christian Lindig --- COVERAGE.md | 45 +++++++++++++++++++++++++++++++++++++ Makefile | 19 +++++++++++++++- _oasis | 13 +++++------ _tags | 38 ++++++++++++++----------------- _tags.coverage | 6 +++++ lib/META | 5 ++--- myocamlbuild.ml | 4 ++-- profiling/META | 12 +++++----- profiling/profiling.mldylib | 4 ++++ profiling/profiling.mllib | 4 ++++ setup.ml | 25 +++++++++------------ 11 files changed, 120 insertions(+), 55 deletions(-) create mode 100644 COVERAGE.md create mode 100644 _tags.coverage create mode 100644 profiling/profiling.mldylib create mode 100644 profiling/profiling.mllib diff --git a/COVERAGE.md b/COVERAGE.md new file mode 100644 index 000000000..d8ea101f1 --- /dev/null +++ b/COVERAGE.md @@ -0,0 +1,45 @@ + +# Coverage Analysis + +This project can be compiled for coverage analysis using [bisect_ppx]. By +default, this is not done. To compile for coverage analysis, do: + + make coverage + make + +The `coverage` target adds the rules in `_tags.coverage` to the `_tags` +file, which in turn causes all code to be compiled for coverage +analysis. The `_tags.coverage` file could be tweaked to control which +files get instrumented. + +## Support Files + +See [profiling/coverage.ml](./profiling/coverage.ml) for the run-time +setup of coverage profiling. This code has no effect when not profiling +during execution. Once [bixect_ppx] has better defaults we could get rid +of it. + +## Execution and Logging + +During program execution, a binary writes coverage data to + + /tmp/bisect--*.out + +This can be overridden by setting the `BISECT_FILE` environment +variable, which is otherwise set at startup using the code in +`profiling/coverage.ml`; + +## Analysis + +See the [bisect_ppx] documentation for details but try from the +top-level directory: + + bisect-ppx-report -I _build -html coverage /tmp/bisect-*.out + +This creates an HTML document in [coverage/](./coverage]. + +[bisect_ppx]: https://github.com/aantron/bisect_ppx + + + + diff --git a/Makefile b/Makefile index 964369dcd..95c971a68 100644 --- a/Makefile +++ b/Makefile @@ -47,4 +47,21 @@ clean: @ocamlbuild -clean @rm -f setup.data setup.log setup.bin rm networkd/version.ml - rm xcp-networkd xcp-networkd.1 + rm xcp-networkd.1 + + +# make coverage +# prepares for building with coverage analysis +# +# make uncover +# reverses the setup from "make coverage" + +coverage: _tags _tags.coverage + test ! -f _tags.orig && mv _tags _tags.orig || true + cat _tags.coverage _tags.orig > _tags + +uncover: _tags.orig + mv _tags.orig _tags + +.PHONY: default coverage uncover + diff --git a/_oasis b/_oasis index 747f663be..bcd654ff2 100644 --- a/_oasis +++ b/_oasis @@ -7,10 +7,10 @@ License: LGPL-2.1 with OCaml linking exception Plugins: META (0.2) BuildTools: ocamlbuild -Library coverage +Library profiling CompiledObject: best Path: profiling - Findlibname: coverage + Install: false Modules: Coverage BuildDepends: @@ -20,7 +20,6 @@ Library networklibs Findlibname: network-libs Modules: Network_config, Network_utils BuildDepends: - bisect_ppx, # coverage profiling forkexec, stdext, threads, @@ -38,7 +37,7 @@ Executable xcp_networkd Custom: true Install: false BuildDepends: - coverage, bisect_ppx, # coverage profiling + profiling, threads, rpclib, rpclib.unix, @@ -58,7 +57,7 @@ Executable networkd_db Custom: true Install: false BuildDepends: - coverage, bisect_ppx, # coverage profiling + profiling, network-libs, stdext, threads, @@ -70,7 +69,7 @@ Executable network_test MainIs: network_test.ml Install: false BuildDepends: - coverage, bisect_ppx, # coverage profiling + profiling, stdext, oUnit, network-libs @@ -85,7 +84,7 @@ Executable cli Path: cli MainIs: network_cli.ml BuildDepends: - coverage, bisect_ppx, # coverage profiling + profiling, cmdliner, stdext, network-libs, diff --git a/_tags b/_tags index d0b19bee2..cbf05519a 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,11 @@ +# START_COVERAGE +# coverage analysis with bisect_ppx +# compile and link with package bisect_ppx +<**/*.ml{,i,y}>: pkg_bisect_ppx +<**/*.native>: pkg_bisect_ppx +# END_COVERAGE # OASIS_START -# DO NOT EDIT (digest: b74bb634db47e28ee82b535b78c98e87) +# DO NOT EDIT (digest: 6a8937157d81341f64a601d75a86be7f) # 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 @@ -14,21 +20,19 @@ true: annot, bin_annot ".git": not_hygienic "_darcs": -traverse "_darcs": not_hygienic -# Library coverage -"profiling/coverage.cmxs": use_coverage +# Library profiling +"profiling/profiling.cmxs": use_profiling # Library networklibs "lib/networklibs.cmxs": use_networklibs : oasis_library_networklibs_ccopt "lib/link_stubs.c": oasis_library_networklibs_ccopt : use_libnetworklibs_stubs -: pkg_bisect_ppx : pkg_forkexec : pkg_rpclib : pkg_stdext : pkg_threads : pkg_xcp-inventory : pkg_xcp.network -"lib/link_stubs.c": pkg_bisect_ppx "lib/link_stubs.c": pkg_forkexec "lib/link_stubs.c": pkg_rpclib "lib/link_stubs.c": pkg_stdext @@ -36,7 +40,6 @@ true: annot, bin_annot "lib/link_stubs.c": pkg_xcp-inventory "lib/link_stubs.c": pkg_xcp.network # Executable xcp_networkd -: pkg_bisect_ppx : pkg_forkexec : pkg_netlink : pkg_rpclib @@ -47,9 +50,8 @@ true: annot, bin_annot : pkg_xcp-inventory : pkg_xcp.network : pkg_xen-api-client -: use_coverage : use_networklibs -: pkg_bisect_ppx +: use_profiling : pkg_forkexec : pkg_netlink : pkg_rpclib @@ -60,31 +62,28 @@ true: annot, bin_annot : pkg_xcp-inventory : pkg_xcp.network : pkg_xen-api-client -: use_coverage : use_networklibs +: use_profiling : custom # Executable networkd_db -: pkg_bisect_ppx : pkg_forkexec : pkg_rpclib : pkg_stdext : pkg_threads : pkg_xcp-inventory : pkg_xcp.network -: use_coverage : use_networklibs -: pkg_bisect_ppx +: use_profiling : pkg_forkexec : pkg_rpclib : pkg_stdext : pkg_threads : pkg_xcp-inventory : pkg_xcp.network -: use_coverage : use_networklibs +: use_profiling : custom # Executable network_test -: pkg_bisect_ppx : pkg_forkexec : pkg_oUnit : pkg_rpclib @@ -92,9 +91,8 @@ true: annot, bin_annot : pkg_threads : pkg_xcp-inventory : pkg_xcp.network -: use_coverage : use_networklibs -: pkg_bisect_ppx +: use_profiling : pkg_forkexec : pkg_oUnit : pkg_rpclib @@ -102,10 +100,9 @@ true: annot, bin_annot : pkg_threads : pkg_xcp-inventory : pkg_xcp.network -: use_coverage : use_networklibs +: use_profiling # Executable cli -: pkg_bisect_ppx : pkg_cmdliner : pkg_forkexec : pkg_rpclib @@ -114,9 +111,8 @@ true: annot, bin_annot : pkg_xcp : pkg_xcp-inventory : pkg_xcp.network -: use_coverage : use_networklibs -: pkg_bisect_ppx +: use_profiling : pkg_cmdliner : pkg_forkexec : pkg_rpclib @@ -125,7 +121,7 @@ true: annot, bin_annot : pkg_xcp : pkg_xcp-inventory : pkg_xcp.network -: use_coverage : use_networklibs +: use_profiling # OASIS_STOP diff --git a/_tags.coverage b/_tags.coverage new file mode 100644 index 000000000..8c543834f --- /dev/null +++ b/_tags.coverage @@ -0,0 +1,6 @@ +# START_COVERAGE +# coverage analysis with bisect_ppx +# compile and link with package bisect_ppx +<**/*.ml{,i,y}>: pkg_bisect_ppx +<**/*.native>: pkg_bisect_ppx +# END_COVERAGE diff --git a/lib/META b/lib/META index 71bc6172a..d698906fb 100644 --- a/lib/META +++ b/lib/META @@ -1,9 +1,8 @@ # OASIS_START -# DO NOT EDIT (digest: 35cbba17e3743e686fa9c799c2fb117d) +# DO NOT EDIT (digest: de99a9d89799ce8282274091a7a1fc5b) version = "0.10.0" description = "XCP Network Daemon" -requires = -"bisect_ppx forkexec stdext threads rpclib stdext xcp-inventory xcp.network" +requires = "forkexec stdext threads rpclib stdext xcp-inventory xcp.network" archive(byte) = "networklibs.cma" archive(byte, plugin) = "networklibs.cma" archive(native) = "networklibs.cmxa" diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 166a70b1a..8184a6b32 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 14ff25fbda4435a4a93036984753949e) *) +(* DO NOT EDIT (digest: cda025dade953b8f1e9b18cca6f3e0fb) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) @@ -608,7 +608,7 @@ open Ocamlbuild_plugin;; let package_default = { MyOCamlbuildBase.lib_ocaml = - [("coverage", ["profiling"], []); ("networklibs", ["lib"], [])]; + [("profiling", ["profiling"], []); ("networklibs", ["lib"], [])]; lib_c = [("networklibs", "lib", ["lib/netdev.h"])]; flags = [ diff --git a/profiling/META b/profiling/META index ee3c14730..00e717fc8 100644 --- a/profiling/META +++ b/profiling/META @@ -1,11 +1,11 @@ # OASIS_START -# DO NOT EDIT (digest: 6e7f6cff169a3b5c960903046d1c6a00) +# DO NOT EDIT (digest: 64d9d987fb0efbdbfeb0624623750120) version = "0.10.0" description = "XCP Network Daemon" -archive(byte) = "coverage.cma" -archive(byte, plugin) = "coverage.cma" -archive(native) = "coverage.cmxa" -archive(native, plugin) = "coverage.cmxs" -exists_if = "coverage.cma" +archive(byte) = "profiling.cma" +archive(byte, plugin) = "profiling.cma" +archive(native) = "profiling.cmxa" +archive(native, plugin) = "profiling.cmxs" +exists_if = "profiling.cma" # OASIS_STOP diff --git a/profiling/profiling.mldylib b/profiling/profiling.mldylib new file mode 100644 index 000000000..2c6e555c2 --- /dev/null +++ b/profiling/profiling.mldylib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 9841bdc50c4226cb6ec5db76494249e6) +Coverage +# OASIS_STOP diff --git a/profiling/profiling.mllib b/profiling/profiling.mllib new file mode 100644 index 000000000..2c6e555c2 --- /dev/null +++ b/profiling/profiling.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 9841bdc50c4226cb6ec5db76494249e6) +Coverage +# OASIS_STOP diff --git a/setup.ml b/setup.ml index e2c079859..79c5d170e 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 8b15e1347b9a64456a33d736cbd939f3) *) +(* DO NOT EDIT (digest: 4f31dde1aa43f140b1636f49feb27ed0) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6906,13 +6906,13 @@ let setup_t = [ Library ({ - cs_name = "coverage"; + cs_name = "profiling"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; bs_path = "profiling"; bs_compiled_object = Best; bs_build_depends = []; @@ -6931,7 +6931,7 @@ let setup_t = lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; - lib_findlib_name = Some "coverage"; + lib_findlib_name = None; lib_findlib_containers = [] }); Library @@ -6947,7 +6947,6 @@ let setup_t = bs_compiled_object = Best; bs_build_depends = [ - FindlibPackage ("bisect_ppx", None); FindlibPackage ("forkexec", None); FindlibPackage ("stdext", None); FindlibPackage ("threads", None); @@ -6991,8 +6990,7 @@ let setup_t = bs_compiled_object = Best; bs_build_depends = [ - InternalLibrary "coverage"; - FindlibPackage ("bisect_ppx", None); + InternalLibrary "profiling"; FindlibPackage ("threads", None); FindlibPackage ("rpclib", None); FindlibPackage ("rpclib.unix", None); @@ -7029,8 +7027,7 @@ let setup_t = bs_compiled_object = Best; bs_build_depends = [ - InternalLibrary "coverage"; - FindlibPackage ("bisect_ppx", None); + InternalLibrary "profiling"; InternalLibrary "networklibs"; FindlibPackage ("stdext", None); FindlibPackage ("threads", None); @@ -7060,8 +7057,7 @@ let setup_t = bs_compiled_object = Best; bs_build_depends = [ - InternalLibrary "coverage"; - FindlibPackage ("bisect_ppx", None); + InternalLibrary "profiling"; FindlibPackage ("stdext", None); FindlibPackage ("oUnit", None); InternalLibrary "networklibs" @@ -7117,8 +7113,7 @@ let setup_t = bs_compiled_object = Best; bs_build_depends = [ - InternalLibrary "coverage"; - FindlibPackage ("bisect_ppx", None); + InternalLibrary "profiling"; FindlibPackage ("cmdliner", None); FindlibPackage ("stdext", None); InternalLibrary "networklibs"; @@ -7144,7 +7139,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; - oasis_digest = Some "\196\216\142i\251!\164t;\014\225\208\002b@n"; + oasis_digest = Some "}\206D\135\159U\248\t\220\245MT)\183S\020"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7152,6 +7147,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7156 "setup.ml" +# 7151 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 9b3607ed25747c5e60ca0297ba46b1bd9cef5859 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Mon, 16 May 2016 12:48:16 +0100 Subject: [PATCH 101/260] CP-17268 update opam, README, INSTALL for coverage profiling Signed-off-by: Christian Lindig --- INSTALL | 13 +++++++++++++ README.markdown | 7 ++++++- opam | 1 + 3 files changed, 20 insertions(+), 1 deletion(-) diff --git a/INSTALL b/INSTALL index 7e66e8e82..f7f3645cd 100644 --- a/INSTALL +++ b/INSTALL @@ -1,7 +1,20 @@ + +# Installation + The easiest way to install is via opam: opam init opam remote add xen-org git://github.com/xen-org/opam-repo-dev opam install xcp-networkd +# Coverage Profiling + +This code can be instrumented for coverage profiling: + + make coverage + make + +See [COVERAGE.md](./COVERAGE.md) for details and +[profiling/](./profiling/) for supporting code. + diff --git a/README.markdown b/README.markdown index f740fc3e3..c65a3cd2a 100644 --- a/README.markdown +++ b/README.markdown @@ -1,8 +1,11 @@ + +# XCP Networkd + Xen API (or xapi) is a management stack that configures and controls Xen-enabled hosts and resource pools, and co-ordinates resources within the pool. Xapi exposes the Xen API interface for many languages and is a component of the Xen Cloud Platform (XCP) project. -Xen API is written mostly in [Ocaml](http://caml.inria.fr/ocaml/) 3.12. +Xen API is written mostly in [OCaml](http://ocaml.org/) 3.12. Xen Cloud Platform (XCP) is an open source enterprise-ready server virtualization and cloud computing platform. XCP builds on the Xen @@ -22,3 +25,5 @@ Links: You can usually find the developers hanging out in #xen-api on freenode. + + diff --git a/opam b/opam index 2be0fa8be..2e4de47f5 100644 --- a/opam +++ b/opam @@ -12,4 +12,5 @@ depends: [ "xen-api-client" "xapi-inventory" "netlink" + "bisect_ppx" ] From 5f1e5eed17d13b0684713618be94cde2bf649fae Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Tue, 17 May 2016 10:23:24 +0100 Subject: [PATCH 102/260] CP-17268 simplify finding temp dir, fix indenation Signed-off-by: Christian Lindig --- Makefile | 14 +++++++------- networkd/networkd.ml | 2 +- profiling/coverage.ml | 35 +++++++++-------------------------- 3 files changed, 17 insertions(+), 34 deletions(-) diff --git a/Makefile b/Makefile index 95c971a68..8811a1839 100644 --- a/Makefile +++ b/Makefile @@ -50,11 +50,9 @@ clean: rm xcp-networkd.1 -# make coverage -# prepares for building with coverage analysis -# -# make uncover -# reverses the setup from "make coverage" +# make coverage - prepares for building with coverage analysis +# make uncover - reverses the setup from "make coverage" +# make report - create coverage/index.html coverage: _tags _tags.coverage test ! -f _tags.orig && mv _tags _tags.orig || true @@ -63,5 +61,7 @@ coverage: _tags _tags.coverage uncover: _tags.orig mv _tags.orig _tags -.PHONY: default coverage uncover - +report: + bisect-ppx-report -I _build -html coverage /tmp/bisect-network*out + +.PHONY: report coverage uncover diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 8a9177101..b1d92e132 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -80,7 +80,7 @@ let doc = String.concat "\n" [ ] let _ = - Coverage.init "networkd"; + Coverage.init "networkd"; begin match Xcp_service.configure2 ~name:Sys.argv.(0) ~version:Version.version diff --git a/profiling/coverage.ml b/profiling/coverage.ml index adc136a55..1dbdff6a6 100644 --- a/profiling/coverage.ml +++ b/profiling/coverage.ml @@ -1,35 +1,18 @@ (** This module sets up the env variable for bisect_ppx which describes - * where log files are writte + * where log files are written. *) -let (//) = Filename.concat - -let is_dir = function - | "" -> false - | path -> try Sys.is_directory path with Sys_error _ -> false - -(* [tmpdir] points to a directory for temporary files *) -let tmpdir = - let getenv n = try Sys.getenv n with Not_found -> "" in - let dirs = - [ getenv "TMP" - ; getenv "TEMP" - ; "/tmp" - ; "/usr/tmp" - ; "/var/tmp" - ] in - try - List.find is_dir dirs - with - Not_found -> failwith "can't find temp directory "^__LOC__ (** [init name] sets up coverage profiling for binary [name]. You could - * use [Sys.argv.(0) for name + * use [Sys.argv.(0)] for [name]. *) + let init name = - try - ignore (Sys.getenv "BISECT_FILE") - with Not_found -> - Unix.putenv "BISECT_FILE" (tmpdir // Printf.sprintf "bisect-%s-" name) + let (//) = Filename.concat in + let tmpdir = Filename.get_temp_dir_name () in + try + ignore (Sys.getenv "BISECT_FILE") + with Not_found -> + Unix.putenv "BISECT_FILE" (tmpdir // Printf.sprintf "bisect-%s-" name) From b2026d21c03d228454b46a33efcbc0d8ee987cf2 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Tue, 17 May 2016 10:55:05 +0100 Subject: [PATCH 103/260] CP-17268 don't use profiling by default This was an oversight in the last commit Signed-off-by: Christian Lindig --- _tags | 6 ------ 1 file changed, 6 deletions(-) diff --git a/_tags b/_tags index cbf05519a..99db9695c 100644 --- a/_tags +++ b/_tags @@ -1,9 +1,3 @@ -# START_COVERAGE -# coverage analysis with bisect_ppx -# compile and link with package bisect_ppx -<**/*.ml{,i,y}>: pkg_bisect_ppx -<**/*.native>: pkg_bisect_ppx -# END_COVERAGE # OASIS_START # DO NOT EDIT (digest: 6a8937157d81341f64a601d75a86be7f) # Ignore VCS directories, you can use the same kind of rule outside From 3f39af7b0376f8720b28b080bdeb193587b1a92f Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Fri, 20 May 2016 12:31:24 +0100 Subject: [PATCH 104/260] CP-17268 fix indentation Signed-off-by: Christian Lindig --- cli/network_cli.ml | 2 +- networkd_db/networkd_db.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/cli/network_cli.ml b/cli/network_cli.ml index 63578dd62..e91e7711d 100644 --- a/cli/network_cli.ml +++ b/cli/network_cli.ml @@ -350,6 +350,6 @@ let cmds = [ config_cmd] let _ = - Coverage.init "network_cli"; + Coverage.init "network_cli"; match Term.eval_choice default_cmd cmds with | `Error _ -> exit 1 | _ -> exit 0 diff --git a/networkd_db/networkd_db.ml b/networkd_db/networkd_db.ml index c15c7560f..7534b6425 100644 --- a/networkd_db/networkd_db.ml +++ b/networkd_db/networkd_db.ml @@ -38,7 +38,7 @@ let _ = (Printf.sprintf "Usage: %s [-bridge | -iface ]" name); try - Coverage.init "network_db"; + Coverage.init "network_db"; let config = Network_config.read_config () in if !bridge <> "" then if List.mem_assoc !bridge config.bridge_config then begin From 4310ea60a796f43910b5c7fdc9c6e38ea4d2ad78 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 31 May 2016 15:36:41 +0100 Subject: [PATCH 105/260] CA-212083: In with_slaves_removed, call `f` if there are no slaves Signed-off-by: Rob Hoes --- lib/network_utils.ml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index cb21be745..7355b8428 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -454,14 +454,12 @@ module Linux_bonding = struct if is_bond_device master then try let slaves = get_bond_slaves master in - if slaves <> [] then begin - Ip.with_links_down slaves (fun () -> - remove_bond_slaves master slaves; - finally - f - (fun () -> add_bond_slaves master slaves) - ) - end + Ip.with_links_down slaves (fun () -> + remove_bond_slaves master slaves; + finally + f + (fun () -> add_bond_slaves master slaves) + ) with _ -> error "Failed to remove or re-add slaves from bond %s" master else @@ -503,10 +501,12 @@ module Linux_bonding = struct let set_bond_properties master properties = if is_bond_device master then begin let current_props = get_bond_properties master in + debug "Current bond properties: %s" (String.concat ", " (List.map (fun (k, v) -> k ^ "=" ^ v) current_props)); (* Find out which properties are known, but different from the current state, * and only continue if there is at least one of those. *) let props_to_update = List.filter (fun (prop, value) -> not (List.mem (prop, value) current_props) && List.mem prop known_props) properties in + debug "Bond properties to update: %s" (String.concat ", " (List.map (fun (k, v) -> k ^ "=" ^ v) props_to_update)); if props_to_update <> [] then let set_prop (prop, value) = try From e5bb50066d632920ba13182640b7b37cc5a59c00 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Mon, 20 Jun 2016 22:18:45 +0100 Subject: [PATCH 106/260] Don't collect stats for loopback and bond devices We don't use the stats for these devices, so lets not spend time on them. Furthermore, due to the fact that the Sysfs.read_one_line and therefore the Sysfs.get_pci_ids function now log errors, and the loopback and bond devices do not have PCI info in sysfs, this was causing lots of log spam. Signed-off-by: Rob Hoes --- networkd/network_monitor_thread.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index 440f81610..bb75374e6 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -31,6 +31,8 @@ let monitor_blacklist = ref [ "xapi"; "ovs-system"; "xenapi"; + "lo"; + "bond"; ] let xapi_rpc request = From fea1b26c24bbff30414a5baf7a43f1f172230fe0 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Thu, 23 Jun 2016 13:33:02 +0100 Subject: [PATCH 107/260] Fix merlin file Signed-off-by: Jon Ludlam --- .merlin | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/.merlin b/.merlin index 4b30ddf1f..0ef04d82c 100644 --- a/.merlin +++ b/.merlin @@ -2,10 +2,10 @@ S lib S networkd S networkd_db S test -B dist/build/lib-network-libs/ -B dist/build/xcp-networkd -B dist/build/networkd_db -B dist/build/network_test +S profiling +B _build/profiling +B _build/lib +B _build/networkd PKG forkexec PKG rpclib PKG stdext @@ -17,3 +17,5 @@ PKG xcp-inventory PKG xcp.network PKG xcp.network PKG xen-api-client +PKG oUnit +PKG bisect_ppx.runtime From 37c9a1e5281739f5bdc83d76b4dc3264a38191e6 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Thu, 23 Jun 2016 13:35:35 +0100 Subject: [PATCH 108/260] Update to using stdext-2.0.0 Signed-off-by: Jon Ludlam --- cli/network_cli.ml | 7 +++---- lib/network_config.ml | 1 + lib/network_utils.ml | 1 + networkd/network_monitor.ml | 6 +----- networkd/network_monitor_thread.ml | 2 +- networkd/network_server.ml | 20 ++++++++++---------- networkd/networkd.ml | 1 + networkd_db/networkd_db.ml | 1 - test/network_test_lacp_properties.ml | 5 ++--- 9 files changed, 20 insertions(+), 24 deletions(-) diff --git a/cli/network_cli.ml b/cli/network_cli.ml index e91e7711d..1e1a62934 100644 --- a/cli/network_cli.ml +++ b/cli/network_cli.ml @@ -1,7 +1,6 @@ open Network_interface open Network_client open Cmdliner -open Xstringext let dbg = "cli" @@ -220,11 +219,11 @@ let get_dns_cmd = let set_dns iface nameservers domains = try let ns = match nameservers with - | Some x -> List.map Unix.inet_addr_of_string (String.split ',' x) + | Some x -> List.map Unix.inet_addr_of_string (Stdext.Xstringext.String.split ',' x) | None -> [] in let d = match domains with - | Some x -> String.split ',' x + | Some x -> Stdext.Xstringext.String.split ',' x | None -> [] in Client.Interface.set_dns dbg iface ns d; @@ -317,7 +316,7 @@ let list_br_cmd = Term.info "list-br" ~doc ~man let read_config path = - let config_json = Unixext.string_of_file path in + let config_json = Stdext.Unixext.string_of_file path in config_json |> Jsonrpc.of_string |> config_t_of_rpc let config path = diff --git a/lib/network_config.ml b/lib/network_config.ml index 2993e7513..13de5b24d 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -14,6 +14,7 @@ open Network_interface +open Stdext open Fun open Xstringext diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 7355b8428..011415106 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -12,6 +12,7 @@ * GNU Lesser General Public License for more details. *) +open Stdext open Listext open Xstringext open Pervasiveext diff --git a/networkd/network_monitor.ml b/networkd/network_monitor.ml index fc6921683..0e485be5b 100644 --- a/networkd/network_monitor.ml +++ b/networkd/network_monitor.ml @@ -15,13 +15,9 @@ open Network_interface include Network_stats -open Fun -open Xstringext -open Threadext - let write_stats stats = let payload = stats |> rpc_of_stats_t |> Jsonrpc.to_string in let checksum = payload |> Digest.string |> Digest.to_hex in let length = String.length payload in let data = Printf.sprintf "%s%s%08x%s" magic checksum length payload in - Unixext.write_string_to_file stats_file (data) + Stdext.Unixext.write_string_to_file stats_file (data) diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index bb75374e6..1d2cfbcf7 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -14,7 +14,7 @@ open Network_utils -open Fun +open Stdext open Xstringext open Listext open Threadext diff --git a/networkd/network_server.ml b/networkd/network_server.ml index fbb47b272..69ba63780 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -15,9 +15,9 @@ open Network_utils open Network_interface -open Fun -open Xstringext -open Listext +(*open Fun*) +open Stdext.Xstringext +open Stdext.Listext module D = Debug.Make(struct let name = "network_server" end) open D @@ -141,7 +141,7 @@ module Interface = struct Ip.flush_ip_addr name end | DHCP4 -> - let gateway = Opt.default [] (Opt.map (fun n -> [`gateway n]) !config.gateway_interface) in + let gateway = Stdext.Opt.default [] (Stdext.Opt.map (fun n -> [`gateway n]) !config.gateway_interface) in let dns = if !config.dns_interface = None || !config.dns_interface = Some name then begin debug "%s is the DNS interface" name; @@ -260,7 +260,7 @@ module Interface = struct let get_dns _ dbg ~name = Debug.with_thread_associated dbg (fun () -> - let nameservers, domains = Unixext.file_lines_fold (fun (nameservers, domains) line -> + let nameservers, domains = Stdext.Unixext.file_lines_fold (fun (nameservers, domains) line -> if String.startswith "nameserver" line then let server = List.nth (String.split_f String.isspace line) 1 in (Unix.inet_addr_of_string server) :: nameservers, domains @@ -284,7 +284,7 @@ module Interface = struct let domains' = if domains <> [] then ["search " ^ (String.concat " " domains)] else [] in let nameservers' = List.map (fun ip -> "nameserver " ^ (Unix.string_of_inet_addr ip)) nameservers in let lines = domains' @ nameservers' in - Unixext.write_string_to_file resolv_conf ((String.concat "\n" lines) ^ "\n") + Stdext.Unixext.write_string_to_file resolv_conf ((String.concat "\n" lines) ^ "\n") end else debug "%s is NOT the DNS interface" name ) () @@ -424,7 +424,7 @@ module Bridge = struct let determine_backend () = try - let backend = String.strip String.isspace (Unixext.string_of_file !network_conf) in + let backend = String.strip String.isspace (Stdext.Unixext.string_of_file !network_conf) in match backend with | "openvswitch" | "vswitch" -> backend_kind := Openvswitch | "bridge" -> backend_kind := Bridge @@ -503,7 +503,7 @@ module Bridge = struct ignore (Brctl.create_bridge name); Brctl.set_forwarding_delay name 0; Sysfs.set_multicast_snooping name false; - Opt.iter (Ip.set_mac name) mac; + Stdext.Opt.iter (Ip.set_mac name) mac; match vlan with | None -> () | Some (parent, vlan) -> @@ -852,12 +852,12 @@ let on_startup () = (* Remove DNSDEV and GATEWAYDEV from Centos networking file, because the interfere * with this daemon. *) try - let file = String.rtrim (Unixext.string_of_file "/etc/sysconfig/network") in + let file = String.rtrim (Stdext.Unixext.string_of_file "/etc/sysconfig/network") in let args = String.split '\n' file in let args = List.map (fun s -> match (String.split '=' s) with k :: [v] -> k, v | _ -> "", "") args in let args = List.filter (fun (k, v) -> k <> "DNSDEV" && k <> "GATEWAYDEV") args in let s = String.concat "\n" (List.map (fun (k, v) -> k ^ "=" ^ v) args) ^ "\n" in - Unixext.write_string_to_file "/etc/sysconfig/network" s + Stdext.Unixext.write_string_to_file "/etc/sysconfig/network" s with _ -> () in try diff --git a/networkd/networkd.ml b/networkd/networkd.ml index b1d92e132..9929de17f 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -12,6 +12,7 @@ * GNU Lesser General Public License for more details. *) +open Stdext open Pervasiveext open Fun open Network_utils diff --git a/networkd_db/networkd_db.ml b/networkd_db/networkd_db.ml index 7534b6425..9fa176e57 100644 --- a/networkd_db/networkd_db.ml +++ b/networkd_db/networkd_db.ml @@ -12,7 +12,6 @@ * GNU Lesser General Public License for more details. *) -open Fun open Network_interface let name = "networkd_db" diff --git a/test/network_test_lacp_properties.ml b/test/network_test_lacp_properties.ml index 0ed52f626..a2e7134da 100644 --- a/test/network_test_lacp_properties.ml +++ b/test/network_test_lacp_properties.ml @@ -12,7 +12,6 @@ * GNU Lesser General Public License for more details. *) -open Fun open OUnit open Network_utils @@ -91,7 +90,7 @@ let test_lacp_aggregation_key_vsctl arg () = skip_if true "Unimplemented" ; print_endline answer ; assert_bool "lacp_aggregation_key is passed to ovs-vsctl command" (List.exists - (fun s -> (Xstringext.String.(strip isspace s) == answer)) + (fun s -> (Stdext.Xstringext.String.(strip isspace s) == answer)) !OVS_Cli_test.vsctl_output) (* Test case for bond_create with default lacp-{time,aggregation-key} settings. @@ -115,7 +114,7 @@ let test_lacp_defaults_bond_create () = List.iter (fun arg -> assert_bool "key=value argument pairs can't have missing values" - (let open Xstringext.String in + (let open Stdext.Xstringext.String in arg |> strip isspace |> endswith "=" |> not)) !OVS_Cli_test.vsctl_output From 344621d1277be98dd45a2b7ac7c9114babb3adad Mon Sep 17 00:00:00 2001 From: Sharad Yadav Date: Mon, 27 Jun 2016 09:20:32 +0100 Subject: [PATCH 109/260] CA-211108: Don't consider the number beside the bond mode in sysfs The bond mode node in sysfs includes a number beside the name of the mode. We should not consider this number while comparing current-state with desired-state to re-apply the mode. Signed-off-by: Sharad Yadav --- lib/network_utils.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 7355b8428..4bb598893 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -487,7 +487,10 @@ module Linux_bonding = struct if is_bond_device master then begin let get_prop prop = try - Some (prop, Sysfs.read_one_line (Sysfs.getpath master ("bonding/" ^ prop))) + let bond_prop = Sysfs.read_one_line (Sysfs.getpath master ("bonding/" ^ prop)) in + if prop = "mode" then + Some (prop, List.hd (String.split ' ' bond_prop)) + else Some (prop, bond_prop) with _ -> debug "Failed to get property \"%s\" on bond %s" prop master; None From 0b1198ad79d2549890d3012c5dde316ead0768f8 Mon Sep 17 00:00:00 2001 From: sharad yadav Date: Tue, 28 Jun 2016 08:10:06 +0000 Subject: [PATCH 110/260] CA-201728: Add new function `has_vlan`. 1) Function `has_vlan` will identify the VLAN which is in use by kernel and unknown to XAPI. 2) PIF.plug for VLAN PIF must fail with new exception `Vlan_in_use` if VLAN is in use by kernel and unknown to XAPI. Signed-off-by: sharad yadav --- lib/network_utils.ml | 13 +++++++++++++ networkd/network_server.ml | 40 +++++++++++++++++++++++++------------- 2 files changed, 40 insertions(+), 13 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 7355b8428..d4ee471c6 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -674,6 +674,19 @@ module Proc = struct else raise Not_found +let get_vlans () = + try + Unixext.file_lines_fold (fun vlans line -> + try + let x = Scanf.sscanf line "%s | %d | %s" (fun device vlan parent -> device, vlan, parent) in + x :: vlans + with _ -> + vlans + ) [] "/proc/net/vlan/config" + with e -> + error "Error: could not read /proc/net/vlan/config"; + [] + let get_bond_links_up name = let statusses = get_bond_slave_info name "MII Status" in List.fold_left (fun x (_, y) -> x + (if y = "up" then 1 else 0)) 0 statusses diff --git a/networkd/network_server.ml b/networkd/network_server.ml index fbb47b272..0470a6f11 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -336,6 +336,12 @@ module Interface = struct Sysfs.is_physical name ) () + let has_vlan _ dbg ~name ~vlan = + (* Identify the vlan is used by kernel which is unknown to XAPI *) + Debug.with_thread_associated dbg (fun () -> + List.exists (fun (_, v, p) -> v = vlan && p = name) (Proc.get_vlans ()) + ) () + let bring_up _ dbg ~name = Debug.with_thread_associated dbg (fun () -> debug "Bringing up interface %s" name; @@ -507,18 +513,7 @@ module Bridge = struct match vlan with | None -> () | Some (parent, vlan) -> - (* Robustness enhancement: ensure there are no other VLANs in the bridge *) - let current_interfaces = List.filter (fun n -> - String.startswith "eth" n || String.startswith "bond" n - ) (Sysfs.bridge_to_interfaces name) in - debug "Removing these non-VIF interfaces found on the bridge: %s" - (String.concat ", " current_interfaces); - List.iter (fun interface -> - Brctl.destroy_port name interface; - Interface.bring_down () dbg ~name:interface - ) current_interfaces; - - (* Now create the new VLAN device and add it to the bridge *) + let bridge_interfaces = Sysfs.bridge_to_interfaces name in let parent_bridge_interface = List.hd (List.filter (fun n -> String.startswith "eth" n || String.startswith "bond" n ) (Sysfs.bridge_to_interfaces parent)) in @@ -532,8 +527,27 @@ module Bridge = struct end else parent_bridge_interface in - Ip.create_vlan parent_interface vlan; let vlan_name = Ip.vlan_name parent_interface vlan in + (* Check if the VLAN is already in use by something else *) + List.iter (fun (device, vlan', parent') -> + (* A device for the same VLAN (parent + tag), but with a different + * device name or not on the requested bridge is bad. *) + if parent' = parent && vlan' = vlan && + (device <> vlan_name || not (List.mem device bridge_interfaces)) then + raise (Vlan_in_use (parent, vlan)) + ) (Proc.get_vlans ()); + (* Robustness enhancement: ensure there are no other VLANs in the bridge *) + let current_interfaces = List.filter (fun n -> + String.startswith "eth" n || String.startswith "bond" n + ) bridge_interfaces in + debug "Removing these non-VIF interfaces found on the bridge: %s" + (String.concat ", " current_interfaces); + List.iter (fun interface -> + Brctl.destroy_port name interface; + Interface.bring_down () dbg ~name:interface + ) current_interfaces; + (* Now create the new VLAN device and add it to the bridge *) + Ip.create_vlan parent_interface vlan; Interface.bring_up () dbg ~name:vlan_name; Brctl.create_port name vlan_name end; From f3c0979da764329674928150812068eba34eaa19 Mon Sep 17 00:00:00 2001 From: Rafal Mielniczuk Date: Tue, 5 Jul 2016 13:57:29 +0000 Subject: [PATCH 111/260] CP-15132: Add systemd notify call Notify systemd when the daemon is ready Signed-off-by: Rafal Mielniczuk --- _oasis | 6 ++++-- _tags | 12 +++++++++++- lib/META | 5 +++-- networkd/network_server.ml | 2 +- networkd/networkd.ml | 2 ++ opam | 1 + setup.ml | 12 +++++++----- 7 files changed, 29 insertions(+), 11 deletions(-) diff --git a/_oasis b/_oasis index bcd654ff2..07cbb0393 100644 --- a/_oasis +++ b/_oasis @@ -26,7 +26,8 @@ Library networklibs rpclib, stdext, xcp-inventory, - xcp.network + xcp.network, + systemd CSources: link_stubs.c, netdev.h CCOpt: -Wno-unused-function -g -ggdb @@ -48,7 +49,8 @@ Executable xcp_networkd xen-api-client, xcp, xcp.network, - netlink + netlink, + systemd Executable networkd_db CompiledObject: best diff --git a/_tags b/_tags index 99db9695c..5f2728da6 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 6a8937157d81341f64a601d75a86be7f) +# DO NOT EDIT (digest: f215aeb9d2f9547603c4304cd27da833) # 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 @@ -24,12 +24,14 @@ true: annot, bin_annot : pkg_forkexec : pkg_rpclib : pkg_stdext +: pkg_systemd : pkg_threads : pkg_xcp-inventory : pkg_xcp.network "lib/link_stubs.c": pkg_forkexec "lib/link_stubs.c": pkg_rpclib "lib/link_stubs.c": pkg_stdext +"lib/link_stubs.c": pkg_systemd "lib/link_stubs.c": pkg_threads "lib/link_stubs.c": pkg_xcp-inventory "lib/link_stubs.c": pkg_xcp.network @@ -39,6 +41,7 @@ true: annot, bin_annot : pkg_rpclib : pkg_rpclib.unix : pkg_stdext +: pkg_systemd : pkg_threads : pkg_xcp : pkg_xcp-inventory @@ -51,6 +54,7 @@ true: annot, bin_annot : pkg_rpclib : pkg_rpclib.unix : pkg_stdext +: pkg_systemd : pkg_threads : pkg_xcp : pkg_xcp-inventory @@ -63,6 +67,7 @@ true: annot, bin_annot : pkg_forkexec : pkg_rpclib : pkg_stdext +: pkg_systemd : pkg_threads : pkg_xcp-inventory : pkg_xcp.network @@ -71,6 +76,7 @@ true: annot, bin_annot : pkg_forkexec : pkg_rpclib : pkg_stdext +: pkg_systemd : pkg_threads : pkg_xcp-inventory : pkg_xcp.network @@ -82,6 +88,7 @@ true: annot, bin_annot : pkg_oUnit : pkg_rpclib : pkg_stdext +: pkg_systemd : pkg_threads : pkg_xcp-inventory : pkg_xcp.network @@ -91,6 +98,7 @@ true: annot, bin_annot : pkg_oUnit : pkg_rpclib : pkg_stdext +: pkg_systemd : pkg_threads : pkg_xcp-inventory : pkg_xcp.network @@ -101,6 +109,7 @@ true: annot, bin_annot : pkg_forkexec : pkg_rpclib : pkg_stdext +: pkg_systemd : pkg_threads : pkg_xcp : pkg_xcp-inventory @@ -111,6 +120,7 @@ true: annot, bin_annot : pkg_forkexec : pkg_rpclib : pkg_stdext +: pkg_systemd : pkg_threads : pkg_xcp : pkg_xcp-inventory diff --git a/lib/META b/lib/META index d698906fb..8bff2b223 100644 --- a/lib/META +++ b/lib/META @@ -1,8 +1,9 @@ # OASIS_START -# DO NOT EDIT (digest: de99a9d89799ce8282274091a7a1fc5b) +# DO NOT EDIT (digest: 15141d14f3a161ffac233e3e5d89f7eb) version = "0.10.0" description = "XCP Network Daemon" -requires = "forkexec stdext threads rpclib stdext xcp-inventory xcp.network" +requires = +"forkexec stdext threads rpclib stdext xcp-inventory xcp.network systemd" archive(byte) = "networklibs.cma" archive(byte, plugin) = "networklibs.cma" archive(native) = "networklibs.cmxa" diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 53fbdf169..b5a81da24 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -30,7 +30,7 @@ let backend_kind = ref Openvswitch let legacy_management_interface_start () = try - ignore (call_script "/etc/init.d/management-interface" ["start"]); + ignore (call_script "/opt/xensource/libexec/legacy-management-interface" ["start"]); debug "Upgrade: brought up interfaces using the old script. Xapi will sync up soon." with e -> debug "Error while configuring the management interface using the old script: %s\n%s" diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 9929de17f..20b11b32a 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -108,6 +108,8 @@ let _ = Debug.with_thread_associated "main" start server ) (); + ignore (Daemon.notify Daemon.State.Ready); + while true do Thread.delay 300.; Network_server.on_timer () diff --git a/opam b/opam index 2e4de47f5..7799a1733 100644 --- a/opam +++ b/opam @@ -7,6 +7,7 @@ build: [ remove: [make "uninstall" "BINDIR=%{bin}%" "SBINDIR=%{bin}%" "LIBEXECDIR=%{bin}%" "SCRIPTSDIR=%{bin}%" "ETCDIR=%{prefix}%/etc"] depends: [ "ocamlfind" + "systemd" "xapi-idl" "xapi-libs-transitional" "xen-api-client" diff --git a/setup.ml b/setup.ml index 79c5d170e..a819a2f22 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 4f31dde1aa43f140b1636f49feb27ed0) *) +(* DO NOT EDIT (digest: e88d0ea8e077829e068fc22c3f10f7eb) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6953,7 +6953,8 @@ let setup_t = FindlibPackage ("rpclib", None); FindlibPackage ("stdext", None); FindlibPackage ("xcp-inventory", None); - FindlibPackage ("xcp.network", None) + FindlibPackage ("xcp.network", None); + FindlibPackage ("systemd", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = ["link_stubs.c"; "netdev.h"]; @@ -7001,7 +7002,8 @@ let setup_t = FindlibPackage ("xen-api-client", None); FindlibPackage ("xcp", None); FindlibPackage ("xcp.network", None); - FindlibPackage ("netlink", None) + FindlibPackage ("netlink", None); + FindlibPackage ("systemd", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -7139,7 +7141,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; - oasis_digest = Some "}\206D\135\159U\248\t\220\245MT)\183S\020"; + oasis_digest = Some "\n\160_\159\237\2314&\159U\152l%\br{"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7147,6 +7149,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7151 "setup.ml" +# 7153 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 9d5309e8018664ed2766e52aeeb1f39d26c5a88d Mon Sep 17 00:00:00 2001 From: Sharad Yadav Date: Wed, 24 Aug 2016 07:10:08 +0100 Subject: [PATCH 112/260] CA-219257: Make enic driver workaround configurable. From xcp-networkd.conf file we can configure enic-workaround-until-version="x.x.x.x" to the version till enic driver workaround will be applied or set the version to an empty string for not applying the workaround. Signed-off-by: Sharad Yadav --- lib/network_utils.ml | 7 +++++++ networkd/network_server.ml | 21 ++++++++++++++++++++- networkd/networkd.ml | 2 +- xcp-networkd.conf | 3 +++ 4 files changed, 31 insertions(+), 2 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index aeaccc5b2..c9aa5f253 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -74,6 +74,13 @@ module Sysfs = struct warn "Failed to obtain list of drivers from sysfs"; [] + let get_driver_version driver () = + try + Some (String.strip String.isspace (Unixext.string_of_file ("/sys/bus/pci/drivers/" ^ driver ^ "/module/version"))) + with _ -> + warn "Failed to obtain driver version from sysfs"; + None + let getpath dev attr = Printf.sprintf "/sys/class/net/%s/%s" dev attr diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 53fbdf169..36c5e1bae 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -27,6 +27,7 @@ type context = unit let network_conf = ref "/etc/xcp/network.conf" let config : config_t ref = ref empty_config let backend_kind = ref Openvswitch +let enic_workaround_until_version = ref "2.3.0.30" let legacy_management_interface_start () = try @@ -85,12 +86,30 @@ let set_dns_interface _ dbg ~name = debug "Setting DNS interface to %s" name; config := {!config with dns_interface = Some name} +(* Returns `true` if vs1 is older than vs2 *) +let is_older_version vs1 vs2 () = + try + let list_of_version vs = List.map int_of_string (String.split '.' vs) in + let rec loop vs1' vs2' = + match vs1', vs2' with + | [], _ | _, [] -> false + | a :: _, b :: _ when a < b -> true + | _ :: tl1, _ :: tl2 -> loop tl1 tl2 + in + loop (list_of_version vs1) (list_of_version vs2) + with _ -> + warn "Failed to compare driver version."; + false + (* The enic driver is for Cisco UCS devices. The current driver adds VLAN0 headers * to all incoming packets, which confuses certain guests OSes. The workaround * constitutes adding a VLAN0 Linux device to strip those headers again. *) let need_enic_workaround () = - !backend_kind = Bridge && List.mem "enic" (Sysfs.list_drivers ()) + !backend_kind = Bridge && List.mem "enic" (Sysfs.list_drivers ()) && (!enic_workaround_until_version <> "") && ( + match Sysfs.get_driver_version "enic" () with + | Some vs -> (is_older_version vs !enic_workaround_until_version ()) + | None -> false ) module Interface = struct let get_config name = diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 9929de17f..b0041e95a 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -53,9 +53,9 @@ let resources = [ let options = [ "monitor_blacklist", Arg.String (fun x -> Network_monitor_thread.monitor_blacklist := String.split ',' x), (fun () -> String.concat "," !Network_monitor_thread.monitor_blacklist), "List of prefixes of interface names that are not to be monitored"; "mac-table-size", Arg.Set_int Network_utils.mac_table_size, (fun () -> string_of_int !Network_utils.mac_table_size), "Default value for the mac-table-size openvswitch parameter (see ovs-vswitchd.conf.db.5)"; + "enic-workaround-until-version", Arg.Set_string Network_server.enic_workaround_until_version, (fun () -> !Network_server.enic_workaround_until_version), "The version till enic driver workaround will be applied or the version set to an empty string for not applying the workaround."; ] - let start server = Network_monitor_thread.start (); Network_server.on_startup (); diff --git a/xcp-networkd.conf b/xcp-networkd.conf index 1e7e9d04a..231eaf354 100644 --- a/xcp-networkd.conf +++ b/xcp-networkd.conf @@ -18,3 +18,6 @@ #The list of prefix interfaces that are not to be monitored #monitor-blacklist=dummy,xenbr,xapi,ovs-system,xenapi + +# The version till enic driver workaround will be applied or set the version to an empty string for not applying the workaround. +# enic-workaround-until-version = "2.3.0.30" From 6d6648670d4d2caed93eba01ec338a6bcfbf1f62 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 21 Jun 2016 23:08:43 +0100 Subject: [PATCH 113/260] CP-17786: Add option to create an internal OVS port Signed-off-by: Rob Hoes --- lib/network_utils.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index c9aa5f253..77a433a71 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -919,8 +919,10 @@ module Ovs = struct List.map (fun (n, _) -> n) vlans_on_bridge with _ -> [] - let create_port name bridge = - vsctl ~log:true ["--"; "--may-exist"; "add-port"; bridge; name] + let create_port ?(internal=false) name bridge = + let type_args = + if internal then ["--"; "set"; "interface"; name; "type=internal"] else [] in + vsctl ~log:true (["--"; "--may-exist"; "add-port"; bridge; name] @ type_args) let destroy_port name = vsctl ~log:true ["--"; "--with-iface"; "--if-exists"; "del-port"; name] From b09ed3539690a89a1b46e7841ac7394e78cc49c2 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 21 Jun 2016 23:09:43 +0100 Subject: [PATCH 114/260] CP-17786: Don't collect stats for PVS-proxy devices Signed-off-by: Rob Hoes --- networkd/network_monitor_thread.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index 1d2cfbcf7..0ce04330f 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -33,6 +33,7 @@ let monitor_blacklist = ref [ "xenapi"; "lo"; "bond"; + "pvs"; ] let xapi_rpc request = From 66cc41e68eee1d1f7910b6844958c82ab305047f Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 21 Jun 2016 23:10:36 +0100 Subject: [PATCH 115/260] CP-17786: Handle `kind` parameter in Bridge.add_port Signed-off-by: Rob Hoes --- networkd/network_server.ml | 121 +++++++++++++++++++++---------------- 1 file changed, 68 insertions(+), 53 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index c7a2b9679..455a111b3 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -718,7 +718,66 @@ module Bridge = struct | Bridge -> () ) () - let add_port _ dbg ?bond_mac ~bridge ~name ~interfaces ?(bond_properties=[]) () = + let add_basic_port dbg bridge name {interfaces; bond_mac; bond_properties} = + match !backend_kind with + | Openvswitch -> + if List.length interfaces = 1 then begin + List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces; + ignore (Ovs.create_port (List.hd interfaces) bridge) + end else begin + if bond_mac = None then + warn "No MAC address specified for the bond"; + ignore (Ovs.create_bond ?mac:bond_mac name interfaces bridge bond_properties); + List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces + end; + if List.mem bridge !add_default then begin + let mac = match bond_mac with + | None -> (try Some (Ip.get_mac name) with _ -> None) + | Some mac -> Some mac + in + match mac with + | Some mac -> + add_default_flows () dbg bridge mac interfaces; + add_default := List.filter ((<>) bridge) !add_default + | None -> + warn "Could not add default flows for port %s on bridge %s because no MAC address was specified" + name bridge + end + | Bridge -> + if List.length interfaces = 1 then + List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces + else begin + Linux_bonding.add_bond_master name; + let bond_properties = + if List.mem_assoc "mode" bond_properties && List.assoc "mode" bond_properties = "lacp" then + List.replace_assoc "mode" "802.3ad" bond_properties + else bond_properties + in + Linux_bonding.set_bond_properties name bond_properties; + Linux_bonding.set_bond_slaves name interfaces; + begin match bond_mac with + | Some mac -> Ip.set_mac name mac + | None -> warn "No MAC address specified for the bond" + end; + Interface.bring_up () dbg ~name + end; + if need_enic_workaround () then begin + debug "Applying enic workaround: adding VLAN0 device to bridge"; + Ip.create_vlan name 0; + let vlan0 = Ip.vlan_name name 0 in + Interface.bring_up () dbg ~name:vlan0; + ignore (Brctl.create_port bridge vlan0) + end else + ignore (Brctl.create_port bridge name) + + let add_pvs_proxy_port dbg bridge name port = + match !backend_kind with + | Openvswitch -> + ignore (Ovs.create_port ~internal:true name bridge) + | Bridge -> + raise Not_implemented + + let add_port _ dbg ?bond_mac ~bridge ~name ~interfaces ?(bond_properties=[]) ?(kind=Basic) () = Debug.with_thread_associated dbg (fun () -> let config = get_config bridge in let ports = @@ -727,61 +786,17 @@ module Bridge = struct else config.ports in - let ports = (name, {interfaces; bond_mac; bond_properties}) :: ports in + let port = {interfaces; bond_mac; bond_properties; kind} in + let ports = (name, port) :: ports in update_config bridge {config with ports}; - debug "Adding port %s to bridge %s with interfaces %s%s" name bridge + debug "Adding %s port %s to bridge %s with interface(s) %s%s" + (string_of_port_kind kind) + name bridge (String.concat ", " interfaces) (match bond_mac with Some mac -> " and MAC " ^ mac | None -> ""); - match !backend_kind with - | Openvswitch -> - if List.length interfaces = 1 then begin - List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces; - ignore (Ovs.create_port (List.hd interfaces) bridge) - end else begin - if bond_mac = None then - warn "No MAC address specified for the bond"; - ignore (Ovs.create_bond ?mac:bond_mac name interfaces bridge bond_properties); - List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces - end; - if List.mem bridge !add_default then begin - let mac = match bond_mac with - | None -> (try Some (Ip.get_mac name) with _ -> None) - | Some mac -> Some mac - in - match mac with - | Some mac -> - add_default_flows () dbg bridge mac interfaces; - add_default := List.filter ((<>) bridge) !add_default - | None -> - warn "Could not add default flows for port %s on bridge %s because no MAC address was specified" - name bridge - end - | Bridge -> - if List.length interfaces = 1 then - List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces - else begin - Linux_bonding.add_bond_master name; - let bond_properties = - if List.mem_assoc "mode" bond_properties && List.assoc "mode" bond_properties = "lacp" then - List.replace_assoc "mode" "802.3ad" bond_properties - else bond_properties - in - Linux_bonding.set_bond_properties name bond_properties; - Linux_bonding.set_bond_slaves name interfaces; - begin match bond_mac with - | Some mac -> Ip.set_mac name mac - | None -> warn "No MAC address specified for the bond" - end; - Interface.bring_up () dbg ~name - end; - if need_enic_workaround () then begin - debug "Applying enic workaround: adding VLAN0 device to bridge"; - Ip.create_vlan name 0; - let vlan0 = Ip.vlan_name name 0 in - Interface.bring_up () dbg ~name:vlan0; - ignore (Brctl.create_port bridge vlan0) - end else - ignore (Brctl.create_port bridge name) + match kind with + | Basic -> add_basic_port dbg bridge name port + | PVS_proxy -> add_pvs_proxy_port dbg bridge name port ) () let remove_port _ dbg ~bridge ~name = From 65bab063021b4801380a34373dcb8c039aa911a1 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 8 Jul 2016 00:41:49 +0100 Subject: [PATCH 116/260] Add JSON-RPC client for stream sockets (not using HTTP) Signed-off-by: Rob Hoes --- _oasis | 2 +- lib/jsonrpc_client.ml | 65 +++++++++++++++++++++++++++++++++++++++++ lib/jsonrpc_client.mli | 20 +++++++++++++ lib/networklibs.mldylib | 3 +- lib/networklibs.mllib | 3 +- setup.ml | 9 +++--- 6 files changed, 95 insertions(+), 7 deletions(-) create mode 100644 lib/jsonrpc_client.ml create mode 100644 lib/jsonrpc_client.mli diff --git a/_oasis b/_oasis index 07cbb0393..7890dedfc 100644 --- a/_oasis +++ b/_oasis @@ -18,7 +18,7 @@ Library networklibs CompiledObject: best Path: lib Findlibname: network-libs - Modules: Network_config, Network_utils + Modules: Network_config, Network_utils, Jsonrpc_client BuildDepends: forkexec, stdext, diff --git a/lib/jsonrpc_client.ml b/lib/jsonrpc_client.ml new file mode 100644 index 000000000..4a08ab65d --- /dev/null +++ b/lib/jsonrpc_client.ml @@ -0,0 +1,65 @@ +(* + * Copyright (C) Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program 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. See the + * GNU Lesser General Public License for more details. + *) + +(* JSON-RPC Client *) + +module D = Debug.Make(struct let name = "jsonrpc_client" end) +open D + +let input_json_object fin = + let buf = Buffer.create 1024 in + let brace_cnt = ref 0 in + let in_string = ref false in + let last_char () = Buffer.nth buf (Buffer.length buf - 1) in + let rec get () = + let c = input_char fin in + begin + match c with + | '{' when not !in_string -> brace_cnt := !brace_cnt + 1 + | '}' when not !in_string -> brace_cnt := !brace_cnt - 1 + | '"' when !in_string && (last_char () <> '\\') -> in_string := false + | '"' when not !in_string -> in_string := true + | _ -> () + end; + Buffer.add_char buf c; + if !brace_cnt > 0 then + get () + in + get (); + Buffer.contents buf + +let receive fin = + let obj = input_json_object fin in + debug "Response: %s" obj; + Jsonrpc.response_of_string obj + +let with_connection sockaddr f = + let fin, fout = Unix.open_connection sockaddr in + debug "Connected."; + let result = f fin fout in + Unix.shutdown_connection fin; + close_in fin; + debug "Shut down."; + result + +let with_rpc ~path ~call = + let sockaddr = Unix.ADDR_UNIX path in + with_connection sockaddr (fun fin fout -> + let req = Jsonrpc.string_of_call call in + debug "Request: %s" req; + output_string fout req; + flush fout; + receive fin + ) + diff --git a/lib/jsonrpc_client.mli b/lib/jsonrpc_client.mli new file mode 100644 index 000000000..7a4220387 --- /dev/null +++ b/lib/jsonrpc_client.mli @@ -0,0 +1,20 @@ +(* + * Copyright (C) Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program 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. See the + * GNU Lesser General Public License for more details. + *) + +(** Do an JSON-RPC call to a server that is listening on a Unix domain + * socket at the given path. *) +val with_rpc : path:string -> call:Rpc.call -> Rpc.response + +(** Read an entire JSON object from an input channel. *) +val input_json_object : in_channel -> string diff --git a/lib/networklibs.mldylib b/lib/networklibs.mldylib index 465d4b7bd..7ce259cfa 100644 --- a/lib/networklibs.mldylib +++ b/lib/networklibs.mldylib @@ -1,5 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: 769536bab5c8cdff920a6b9ddafec2e2) +# DO NOT EDIT (digest: 9ba8d589e3c2bbc8ad11518d00bef3df) Network_config Network_utils +Jsonrpc_client # OASIS_STOP diff --git a/lib/networklibs.mllib b/lib/networklibs.mllib index 465d4b7bd..7ce259cfa 100644 --- a/lib/networklibs.mllib +++ b/lib/networklibs.mllib @@ -1,5 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: 769536bab5c8cdff920a6b9ddafec2e2) +# DO NOT EDIT (digest: 9ba8d589e3c2bbc8ad11518d00bef3df) Network_config Network_utils +Jsonrpc_client # OASIS_STOP diff --git a/setup.ml b/setup.ml index a819a2f22..c995e9119 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: e88d0ea8e077829e068fc22c3f10f7eb) *) +(* DO NOT EDIT (digest: 3ed00f193f4bf440feec3d634289da04) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6971,7 +6971,8 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])] }, { - lib_modules = ["Network_config"; "Network_utils"]; + lib_modules = + ["Network_config"; "Network_utils"; "Jsonrpc_client"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; @@ -7141,7 +7142,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; - oasis_digest = Some "\n\160_\159\237\2314&\159U\152l%\br{"; + oasis_digest = Some "b\163\2003\188\003\000)JW\241w\025\003:I"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7149,6 +7150,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7153 "setup.ml" +# 7154 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 56a09661a622e8c79f505b38b812befb33fb41fe Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 8 Jul 2016 00:53:24 +0100 Subject: [PATCH 117/260] Implement PVS_proxy functions Signed-off-by: Rob Hoes --- networkd/network_server.ml | 25 +++++++++++++++++++++++++ networkd/networkd.ml | 1 + 2 files changed, 26 insertions(+) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 455a111b3..6bfe35364 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -892,6 +892,31 @@ module Bridge = struct ) () end +module PVS_proxy = struct + open PVS_proxy + + let path = ref "/var/run/pvsproxy" + + let do_call call = + try + Jsonrpc_client.with_rpc ~path:!path ~call + with e -> + error "Error when calling PVS proxy: %s" (Printexc.to_string e); + raise PVS_proxy_connection_error + + let configure_farm _ dbg config = + debug "Configuring PVS proxy for farm %s" config.farm_uuid; + let call = {Rpc.name = "configure_farm"; params = [rpc_of_t config]} in + let _ = do_call call in + () + + let remove_farm _ dbg uuid = + debug "Removing PVS proxy for farm %s" uuid; + let call = Rpc.{name = "remove_farm"; params = [Dict ["farm_uuid", rpc_of_string uuid]]} in + let _ = do_call call in + () +end + let on_startup () = let dbg = "startup" in Debug.with_thread_associated dbg (fun () -> diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 94c48fcc1..a862014c9 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -54,6 +54,7 @@ let options = [ "monitor_blacklist", Arg.String (fun x -> Network_monitor_thread.monitor_blacklist := String.split ',' x), (fun () -> String.concat "," !Network_monitor_thread.monitor_blacklist), "List of prefixes of interface names that are not to be monitored"; "mac-table-size", Arg.Set_int Network_utils.mac_table_size, (fun () -> string_of_int !Network_utils.mac_table_size), "Default value for the mac-table-size openvswitch parameter (see ovs-vswitchd.conf.db.5)"; "enic-workaround-until-version", Arg.Set_string Network_server.enic_workaround_until_version, (fun () -> !Network_server.enic_workaround_until_version), "The version till enic driver workaround will be applied or the version set to an empty string for not applying the workaround."; + "pvs-proxy-socket", Arg.Set_string Network_server.PVS_proxy.path, (fun () -> !Network_server.PVS_proxy.path), "Path to the Unix domain socket for the PVS-proxy daemon"; ] let start server = From 0a927b4885c4d99d0e8dc8a37a0bcb418a413cf7 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 12 Jul 2016 00:43:10 +0100 Subject: [PATCH 118/260] Add test JSON-RPC server Signed-off-by: Rob Hoes --- _oasis | 7 +++++++ _tags | 27 ++++++++++++++++++--------- setup.ml | 31 +++++++++++++++++++++++++++---- test/jsonrpc_dummy.ml | 14 ++++++++++++++ 4 files changed, 66 insertions(+), 13 deletions(-) create mode 100644 test/jsonrpc_dummy.ml diff --git a/_oasis b/_oasis index 7890dedfc..5e57c12f6 100644 --- a/_oasis +++ b/_oasis @@ -93,3 +93,10 @@ Executable cli xcp, xcp.network +Executable jsonrpc_dummy + CompiledObject: best + Path: test + MainIs: jsonrpc_dummy.ml + Install: false + BuildDepends: + network-libs diff --git a/_tags b/_tags index 5f2728da6..64a9107ee 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: f215aeb9d2f9547603c4304cd27da833) +# DO NOT EDIT (digest: e04367a949141a8df6b1750a04277a1e) # 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 @@ -94,15 +94,7 @@ true: annot, bin_annot : pkg_xcp.network : use_networklibs : use_profiling -: pkg_forkexec : pkg_oUnit -: pkg_rpclib -: pkg_stdext -: pkg_systemd -: pkg_threads -: pkg_xcp-inventory -: pkg_xcp.network -: use_networklibs : use_profiling # Executable cli : pkg_cmdliner @@ -127,5 +119,22 @@ true: annot, bin_annot : pkg_xcp.network : use_networklibs : use_profiling +# Executable jsonrpc_dummy +: pkg_forkexec +: pkg_rpclib +: pkg_stdext +: pkg_systemd +: pkg_threads +: pkg_xcp-inventory +: pkg_xcp.network +: use_networklibs +: pkg_forkexec +: pkg_rpclib +: pkg_stdext +: pkg_systemd +: pkg_threads +: pkg_xcp-inventory +: pkg_xcp.network +: use_networklibs # OASIS_STOP diff --git a/setup.ml b/setup.ml index c995e9119..d93a8a715 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 3ed00f193f4bf440feec3d634289da04) *) +(* DO NOT EDIT (digest: 28807fae75efecca04afcffe76872e64) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and @@ -7133,7 +7133,30 @@ let setup_t = bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, - {exec_custom = false; exec_main_is = "network_cli.ml"}) + {exec_custom = false; exec_main_is = "network_cli.ml"}); + Executable + ({ + cs_name = "jsonrpc_dummy"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "test"; + bs_compiled_object = Best; + bs_build_depends = [InternalLibrary "networklibs"]; + 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 = false; exec_main_is = "jsonrpc_dummy.ml"}) ]; plugins = [(`Extra, "META", Some "0.2")]; disable_oasis_section = []; @@ -7142,7 +7165,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; - oasis_digest = Some "b\163\2003\188\003\000)JW\241w\025\003:I"; + oasis_digest = Some "9\198\149\142Bm\1860)\015\b\023o\236\213\128"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7150,6 +7173,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7154 "setup.ml" +# 7177 "setup.ml" (* OASIS_STOP *) let () = setup ();; diff --git a/test/jsonrpc_dummy.ml b/test/jsonrpc_dummy.ml new file mode 100644 index 000000000..051b8ba52 --- /dev/null +++ b/test/jsonrpc_dummy.ml @@ -0,0 +1,14 @@ +let path = Sys.argv.(1) + +let _ = + Sys.set_signal Sys.sigint (Sys.Signal_handle (fun _ -> Unix.unlink path; exit 0)); + Unix.establish_server (fun fin fout -> + let rec loop () = + let json = Jsonrpc_client.input_json_object fin in + Printf.printf "Received: %s\n" json; + let response = Jsonrpc.string_of_response (Rpc.success (Rpc.String "Thanks!")) in + Printf.printf "Response: %s\n" response; + output_string fout response + in + loop () + ) (Unix.ADDR_UNIX path) From ea4350ab358027d12e8f3753410553a84665bff9 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 12 Jul 2016 16:02:22 +0100 Subject: [PATCH 119/260] Unit tests for Jsonrpc_client.input_json_object Signed-off-by: Rob Hoes --- _oasis | 3 +- _tags | 4 +- setup.ml | 9 ++-- test/jsonrpc_files/bad_call.json | 1 + test/jsonrpc_files/good_call.json | 1 + test/jsonrpc_files/good_call_plus.json | 1 + test/jsonrpc_files/short_call.json | 1 + test/network_test.ml | 1 + test/test_jsonrpc_client.ml | 74 ++++++++++++++++++++++++++ 9 files changed, 89 insertions(+), 6 deletions(-) create mode 100644 test/jsonrpc_files/bad_call.json create mode 100644 test/jsonrpc_files/good_call.json create mode 100644 test/jsonrpc_files/good_call_plus.json create mode 100644 test/jsonrpc_files/short_call.json create mode 100644 test/test_jsonrpc_client.ml diff --git a/_oasis b/_oasis index 5e57c12f6..4266fa604 100644 --- a/_oasis +++ b/_oasis @@ -74,7 +74,8 @@ Executable network_test profiling, stdext, oUnit, - network-libs + network-libs, + xapi-test-utils Test test_networkd Run$: flag(tests) diff --git a/_tags b/_tags index 64a9107ee..53f061a82 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: e04367a949141a8df6b1750a04277a1e) +# DO NOT EDIT (digest: 6789724751e66864fb1299d08f339eb0) # 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 @@ -90,11 +90,13 @@ true: annot, bin_annot : pkg_stdext : pkg_systemd : pkg_threads +: pkg_xapi-test-utils : pkg_xcp-inventory : pkg_xcp.network : use_networklibs : use_profiling : pkg_oUnit +: pkg_xapi-test-utils : use_profiling # Executable cli : pkg_cmdliner diff --git a/setup.ml b/setup.ml index d93a8a715..b17cb6736 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 28807fae75efecca04afcffe76872e64) *) +(* DO NOT EDIT (digest: ee3c028836cb8490a074295e123698ad) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and @@ -7063,7 +7063,8 @@ let setup_t = InternalLibrary "profiling"; FindlibPackage ("stdext", None); FindlibPackage ("oUnit", None); - InternalLibrary "networklibs" + InternalLibrary "networklibs"; + FindlibPackage ("xapi-test-utils", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -7165,7 +7166,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; - oasis_digest = Some "9\198\149\142Bm\1860)\015\b\023o\236\213\128"; + oasis_digest = Some "N\031\177\159p\148\031\214\203#{\193\028\015_\242"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7173,6 +7174,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7177 "setup.ml" +# 7178 "setup.ml" (* OASIS_STOP *) let () = setup ();; diff --git a/test/jsonrpc_files/bad_call.json b/test/jsonrpc_files/bad_call.json new file mode 100644 index 000000000..7d3e96e52 --- /dev/null +++ b/test/jsonrpc_files/bad_call.json @@ -0,0 +1 @@ +{"method": "method1", "params": [{"param1": "value1", "param2": "value2"}], "id":} diff --git a/test/jsonrpc_files/good_call.json b/test/jsonrpc_files/good_call.json new file mode 100644 index 000000000..40755cb46 --- /dev/null +++ b/test/jsonrpc_files/good_call.json @@ -0,0 +1 @@ +{"method": "method1", "params": [{"param1": "value1", "param2": "}value2{"}], "id": "1"} diff --git a/test/jsonrpc_files/good_call_plus.json b/test/jsonrpc_files/good_call_plus.json new file mode 100644 index 000000000..2b7f14482 --- /dev/null +++ b/test/jsonrpc_files/good_call_plus.json @@ -0,0 +1 @@ +{"method": "method1", "params": [{"param1": "value1", "param2": "}value2{"}], "id": "1"}"more" diff --git a/test/jsonrpc_files/short_call.json b/test/jsonrpc_files/short_call.json new file mode 100644 index 000000000..b90315c4a --- /dev/null +++ b/test/jsonrpc_files/short_call.json @@ -0,0 +1 @@ +{"method": "method1", "params": [{"param1": "value1", "param2": "value2"}], "id": "1" \ No newline at end of file diff --git a/test/network_test.ml b/test/network_test.ml index 39349c20d..e508e117e 100644 --- a/test/network_test.ml +++ b/test/network_test.ml @@ -18,6 +18,7 @@ let base_suite = "base_suite" >::: [ Network_test_lacp_properties.suite; + Test_jsonrpc_client.suite; ] let _ = diff --git a/test/test_jsonrpc_client.ml b/test/test_jsonrpc_client.ml new file mode 100644 index 000000000..2aeb4656f --- /dev/null +++ b/test/test_jsonrpc_client.ml @@ -0,0 +1,74 @@ +(* + * Copyright (C) Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program 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. See the + * GNU Lesser General Public License for more details. + *) + +open OUnit +open Test_highlevel +open Stdext.Either + +let dir = Filename.concat "test" "jsonrpc_files" + +let jsonrpc_printer : Rpc.t Test_printers.printer = + Jsonrpc.to_string + +module Input_json_object = Generic.Make (struct + module Io = struct + type input_t = string + type output_t = (exn, Rpc.t) Stdext.Either.t + let string_of_input_t = Test_printers.string + let string_of_output_t = Test_printers.(either exn jsonrpc_printer) + end + + let good_call = + let fin = open_in (Filename.concat dir "good_call.json") in + let s = input_line fin in + close_in fin; + Jsonrpc.of_string s + + exception Parse_error + + let transform filename = + let fin = open_in (Filename.concat dir filename) in + let response = + try + let json = Jsonrpc_client.input_json_object fin in + let rpc = Jsonrpc.of_string json in + Right rpc + with + | End_of_file -> Left End_of_file + | _ -> Left Parse_error + in + close_in fin; + response + + let tests = [ + (* A file containing exactly one JSON object. *) + (* It has got curly braces inside strings to make it interesting. *) + "good_call.json", Right good_call; + + (* A file containing a partial JSON object. *) + "short_call.json", Left End_of_file; + + (* A file containing a JSON object, plus some more characters at the end. *) + "good_call_plus.json", Right good_call; + + (* A file containing some invalid JSON object. *) + "bad_call.json", (Left Parse_error); + ] +end) + +let suite = + "jsonrpc_client" >::: + [ + "input_json_object" >::: Input_json_object.tests; + ] From df1cc02d2657affaae7d1f6da3514aee0e94e5a0 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Mon, 18 Jul 2016 17:40:44 +0100 Subject: [PATCH 120/260] Bring up PVS port after creating it Signed-off-by: Rob Hoes --- networkd/network_server.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 6bfe35364..03eb819b6 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -773,7 +773,8 @@ module Bridge = struct let add_pvs_proxy_port dbg bridge name port = match !backend_kind with | Openvswitch -> - ignore (Ovs.create_port ~internal:true name bridge) + ignore (Ovs.create_port ~internal:true name bridge); + Interface.bring_up () dbg ~name | Bridge -> raise Not_implemented From fe24cd1496208a6cfe507476ffb2d87320a08a67 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Mon, 18 Jul 2016 17:43:51 +0100 Subject: [PATCH 121/260] CA-216671: Use JSON-RPC v2 to communicate with the PVS proxy Signed-off-by: Rob Hoes --- lib/jsonrpc_client.ml | 4 ++-- lib/jsonrpc_client.mli | 2 +- networkd/network_server.ml | 2 +- test/jsonrpc_dummy.ml | 2 +- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/lib/jsonrpc_client.ml b/lib/jsonrpc_client.ml index 4a08ab65d..e6c228e3f 100644 --- a/lib/jsonrpc_client.ml +++ b/lib/jsonrpc_client.ml @@ -53,10 +53,10 @@ let with_connection sockaddr f = debug "Shut down."; result -let with_rpc ~path ~call = +let with_rpc ?(version=Jsonrpc.V2) ~path ~call () = let sockaddr = Unix.ADDR_UNIX path in with_connection sockaddr (fun fin fout -> - let req = Jsonrpc.string_of_call call in + let req = Jsonrpc.string_of_call ~version call in debug "Request: %s" req; output_string fout req; flush fout; diff --git a/lib/jsonrpc_client.mli b/lib/jsonrpc_client.mli index 7a4220387..c7dd21ee6 100644 --- a/lib/jsonrpc_client.mli +++ b/lib/jsonrpc_client.mli @@ -14,7 +14,7 @@ (** Do an JSON-RPC call to a server that is listening on a Unix domain * socket at the given path. *) -val with_rpc : path:string -> call:Rpc.call -> Rpc.response +val with_rpc : ?version:Jsonrpc.version -> path:string -> call:Rpc.call -> unit -> Rpc.response (** Read an entire JSON object from an input channel. *) val input_json_object : in_channel -> string diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 03eb819b6..c2c72c067 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -900,7 +900,7 @@ module PVS_proxy = struct let do_call call = try - Jsonrpc_client.with_rpc ~path:!path ~call + Jsonrpc_client.with_rpc ~path:!path ~call () with e -> error "Error when calling PVS proxy: %s" (Printexc.to_string e); raise PVS_proxy_connection_error diff --git a/test/jsonrpc_dummy.ml b/test/jsonrpc_dummy.ml index 051b8ba52..b291222be 100644 --- a/test/jsonrpc_dummy.ml +++ b/test/jsonrpc_dummy.ml @@ -6,7 +6,7 @@ let _ = let rec loop () = let json = Jsonrpc_client.input_json_object fin in Printf.printf "Received: %s\n" json; - let response = Jsonrpc.string_of_response (Rpc.success (Rpc.String "Thanks!")) in + let response = Jsonrpc.string_of_response ~version:Jsonrpc.V2 (Rpc.success (Rpc.String "Thanks!")) in Printf.printf "Response: %s\n" response; output_string fout response in From 203cc6928c95a7bad5af3d26bec8ffa3ec53ec74 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Fri, 29 Jul 2016 09:57:27 +0100 Subject: [PATCH 122/260] CP-18299: Rename PVS_farm PVS_site Signed-off-by: Jon Ludlam --- networkd/network_server.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index c2c72c067..882e5e05f 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -905,15 +905,15 @@ module PVS_proxy = struct error "Error when calling PVS proxy: %s" (Printexc.to_string e); raise PVS_proxy_connection_error - let configure_farm _ dbg config = - debug "Configuring PVS proxy for farm %s" config.farm_uuid; - let call = {Rpc.name = "configure_farm"; params = [rpc_of_t config]} in + let configure_site _ dbg config = + debug "Configuring PVS proxy for site %s" config.site_uuid; + let call = {Rpc.name = "configure_site"; params = [rpc_of_t config]} in let _ = do_call call in () - let remove_farm _ dbg uuid = - debug "Removing PVS proxy for farm %s" uuid; - let call = Rpc.{name = "remove_farm"; params = [Dict ["farm_uuid", rpc_of_string uuid]]} in + let remove_site _ dbg uuid = + debug "Removing PVS proxy for site %s" uuid; + let call = Rpc.{name = "remove_site"; params = [Dict ["site_uuid", rpc_of_string uuid]]} in let _ = do_call call in () end From 5e31190e138156ba263a1bb531dcf68f9611375d Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Thu, 29 Sep 2016 14:13:47 +0100 Subject: [PATCH 123/260] Update pvsproxy socket path Signed-off-by: Rob Hoes --- networkd/network_server.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 882e5e05f..00283d187 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -896,7 +896,7 @@ end module PVS_proxy = struct open PVS_proxy - let path = ref "/var/run/pvsproxy" + let path = ref "/opt/citrix/pvsproxy/socket/pvsproxy" let do_call call = try From b5690e7c81140582722edcb40940f2caca8762d7 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 7 Oct 2016 16:39:49 +0100 Subject: [PATCH 124/260] Set no-flood on PVS-proxy ports This adds some protection against unicast floods (which happen as part of MAC learning) getting out of hand. Signed-off-by: Rob Hoes --- lib/network_utils.ml | 4 ++++ networkd/network_server.ml | 1 + 2 files changed, 5 insertions(+) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 77a433a71..ec787d1e3 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -1027,6 +1027,10 @@ module Ovs = struct ) ports) in List.iter (fun flow -> ignore (ofctl ~log:true ["add-flow"; bridge; flow])) flows + + let mod_port bridge port action = + ofctl ~log:true ["mod-port"; bridge; port; action] |> ignore + end include Make(Cli) end diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 00283d187..1ebcb4189 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -774,6 +774,7 @@ module Bridge = struct match !backend_kind with | Openvswitch -> ignore (Ovs.create_port ~internal:true name bridge); + Ovs.mod_port bridge name "no-flood"; Interface.bring_up () dbg ~name | Bridge -> raise Not_implemented From 55059b34ffe70fd3f2ab2a75b39e91c7cdd2c6a4 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Mon, 10 Oct 2016 10:53:22 +0100 Subject: [PATCH 125/260] Change monitor blacklist into whitelist (#90) This way we have tighter control over what interfaces are monitored, which are essentially just PIFs (eth*) and VIFs (vifx.y). Recently, we have had to extend the blacklist several times, because devices with different names appeared, which we do not want to monitor. Signed-off-by: Rob Hoes --- networkd/network_monitor_thread.ml | 29 +++++++++++++++-------------- networkd/networkd.ml | 2 +- 2 files changed, 16 insertions(+), 15 deletions(-) diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index 0ce04330f..19ce16f75 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -25,15 +25,9 @@ open D (** Table for bonds status. *) let bonds_status : (string, (int * int)) Hashtbl.t = Hashtbl.create 10 -let monitor_blacklist = ref [ - "dummy"; - "xenbr"; - "xapi"; - "ovs-system"; - "xenapi"; - "lo"; - "bond"; - "pvs"; +let monitor_whitelist = ref [ + "eth"; + "vif"; (* This includes "tap" owing to the use of standardise_name below *) ] let xapi_rpc request = @@ -110,14 +104,21 @@ let get_link_stats () = let cache = Link.cache_alloc s in let links = Link.cache_to_list cache in let links = + let is_whitelisted name = + List.exists (fun s -> String.startswith s name) !monitor_whitelist + in + let is_vlan name = + String.startswith "eth" name && String.contains name '.' + in List.map (fun link -> (standardise_name (Link.get_name link)), link ) links |> - List.filter (fun (name,link) -> - let is_monitor_blacklisted = List.exists (fun s -> String.startswith s name) !monitor_blacklist || - (String.startswith "eth" name && String.contains name '.') in - not is_monitor_blacklisted - ) in + (* Only keep interfaces with prefixes on the whitelist, and exclude VLAN + devices (ethx.y). *) + List.filter (fun (name, _) -> + is_whitelisted name && not (is_vlan name) + ) + in let devs = List.map (fun (name,link) -> let convert x = Int64.of_int (Unsigned.UInt64.to_int x) in diff --git a/networkd/networkd.ml b/networkd/networkd.ml index a862014c9..30b589872 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -51,7 +51,7 @@ let resources = [ ] let options = [ - "monitor_blacklist", Arg.String (fun x -> Network_monitor_thread.monitor_blacklist := String.split ',' x), (fun () -> String.concat "," !Network_monitor_thread.monitor_blacklist), "List of prefixes of interface names that are not to be monitored"; + "monitor_whitelist", Arg.String (fun x -> Network_monitor_thread.monitor_whitelist := String.split ',' x), (fun () -> String.concat "," !Network_monitor_thread.monitor_whitelist), "List of prefixes of interface names that are to be monitored"; "mac-table-size", Arg.Set_int Network_utils.mac_table_size, (fun () -> string_of_int !Network_utils.mac_table_size), "Default value for the mac-table-size openvswitch parameter (see ovs-vswitchd.conf.db.5)"; "enic-workaround-until-version", Arg.Set_string Network_server.enic_workaround_until_version, (fun () -> !Network_server.enic_workaround_until_version), "The version till enic driver workaround will be applied or the version set to an empty string for not applying the workaround."; "pvs-proxy-socket", Arg.Set_string Network_server.PVS_proxy.path, (fun () -> !Network_server.PVS_proxy.path), "Path to the Unix domain socket for the PVS-proxy daemon"; From d0b67b003581c02425ccc44ca1c85f0602087a8b Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 14 Oct 2016 11:03:46 +0100 Subject: [PATCH 126/260] Call mod-port on parent bridge, not "fake" VLAN bridge Signed-off-by: Rob Hoes --- networkd/network_server.ml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 1ebcb4189..f670e0601 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -774,7 +774,12 @@ module Bridge = struct match !backend_kind with | Openvswitch -> ignore (Ovs.create_port ~internal:true name bridge); - Ovs.mod_port bridge name "no-flood"; + let real_bridge = + match Ovs.bridge_to_vlan bridge with + | Some (parent, _) -> parent + | None -> bridge + in + Ovs.mod_port real_bridge name "no-flood"; Interface.bring_up () dbg ~name | Bridge -> raise Not_implemented From 25e0a6b6742399e3277a82dc3391400d4664ca2a Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Mon, 17 Oct 2016 10:52:55 +0100 Subject: [PATCH 127/260] CA-225365: Trim the output of CLI commands Signed-off-by: Rob Hoes --- lib/network_utils.ml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index ec787d1e3..70d7954f8 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -756,8 +756,12 @@ module Ovs = struct let bridge_to_vlan name = try - Some (vsctl ["br-to-parent"; name], int_of_string (vsctl ["br-to-vlan"; name])) - with _ -> None + let parent = vsctl ["br-to-parent"; name] |> String.rtrim in + let vlan = vsctl ["br-to-vlan"; name] |> String.rtrim |> int_of_string in + Some (parent, vlan) + with e -> + debug "bridge_to_vlan: %s" (Printexc.to_string e); + None let get_bond_link_status name = try From ad913f9efb945b98ab95c31b55262318b10ff3ad Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Thu, 20 Oct 2016 14:40:27 +0100 Subject: [PATCH 128/260] CA-225272: rate-limit calls to `ovs-vsctl` (#93) Signed-off-by: Marcello Seri --- lib/network_utils.ml | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 70d7954f8..7112b2c5c 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -705,9 +705,16 @@ end module Ovs = struct - module Cli = struct + module Cli : sig + val vsctl : ?log:bool -> string list -> string + val ofctl : ?log:bool -> string list -> string + val appctl : ?log:bool -> string list -> string + end = struct + let s = Semaphore.create 5 let vsctl ?(log=false) args = - call_script ~log_successful_output:log ovs_vsctl ("--timeout=20" :: args) + Semaphore.execute s (fun () -> + call_script ~log_successful_output:log ovs_vsctl ("--timeout=20" :: args) + ) let ofctl ?(log=false) args = call_script ~log_successful_output:log ovs_ofctl args let appctl ?(log=false) args = From 95f5d8af61fec2d512fbaed2ef7abbedaa76adea Mon Sep 17 00:00:00 2001 From: Euan Harris Date: Mon, 7 Nov 2016 09:51:32 +0000 Subject: [PATCH 129/260] git: Add metadata to the result of `git archive` Have `git archive` automatically fill in metadata at the point of creating the archive, which makes it easier to track back from released packages to the source code which was used to build them. .gitarchive-info will contain something like the following: > Changeset: ccd5d2e265d1d629004aa05f6f873ab6f49555c2 > Commit date: Mon, 7 Nov 2016 09:51:32 +0000 Based on https://xenbits.xen.org/gitweb/?p=xen.git;a=commitdiff;h=bd4d31be073166fc69b131e6375b55033b83b1c0 Suggested-by: Andrew Cooper Signed-off-by: Euan Harris --- .gitarchive-info | 2 ++ .gitattributes | 1 + 2 files changed, 3 insertions(+) create mode 100644 .gitarchive-info create mode 100644 .gitattributes diff --git a/.gitarchive-info b/.gitarchive-info new file mode 100644 index 000000000..83e5b86e5 --- /dev/null +++ b/.gitarchive-info @@ -0,0 +1,2 @@ +Changeset: $Format:%H$ +Commit date: $Format:%cD$ diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 000000000..f7bf506d3 --- /dev/null +++ b/.gitattributes @@ -0,0 +1 @@ +.gitarchive-info export-subst From 1836c1bdb44b89a5f8784a8320001e1d98a124a8 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 2 Dec 2016 15:44:52 +0000 Subject: [PATCH 130/260] CA-234506: Don't lose the port `kind` param in bridge.make_config This (relatively new) kind parameter was not passed on to the function that adds the port to the bridge, so that it would add a port of the wrong kind. Signed-off-by: Rob Hoes --- networkd/network_server.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index f670e0601..000c6438d 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -891,8 +891,8 @@ module Bridge = struct update_config bridge_name c; exec (fun () -> create () dbg ?vlan ?mac:bridge_mac ~other_config ~name:bridge_name (); - List.iter (fun (port_name, {interfaces; bond_properties; bond_mac}) -> - add_port () dbg ?bond_mac ~bridge:bridge_name ~name:port_name ~interfaces ~bond_properties () + List.iter (fun (port_name, {interfaces; bond_properties; bond_mac; kind}) -> + add_port () dbg ?bond_mac ~bridge:bridge_name ~name:port_name ~interfaces ~bond_properties ~kind () ) ports ) ) config From 9f6882bae3632aa36ed3045c7f44f84057c08bfc Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Thu, 19 Jan 2017 16:24:55 +0000 Subject: [PATCH 131/260] CA-239919: network_utils, define Ip.del_ip_addr Signed-off-by: Marcello Seri --- lib/network_utils.ml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 7112b2c5c..eb7b1278e 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -333,6 +333,12 @@ info "Found at [ %s ]" (String.concat ", " (List.map string_of_int indices)); let mode = if ipv6 then "-6" else "-4" in ignore (call ~log:true [mode; "addr"; "flush"; "dev"; dev]) with _ -> () + + let del_ip_addr dev (ip, prefixlen) = + let addr = Printf.sprintf "%s/%d" (Unix.string_of_inet_addr ip) prefixlen in + try + ignore (call ~log:true ["addr"; "del"; addr; "dev"; dev]) + with _ -> () let route_show ?(version=V46) dev = let v = string_of_version version in From 42cf2e82fe3c0a2d8a6f3552b43ca88bd5f75f54 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Thu, 19 Jan 2017 16:26:48 +0000 Subject: [PATCH 132/260] CA-239919: Static IP briefly flushed when Static IPv4 is set Redefine `Interface.set_ipv4_conf` to keep being idempotent but avoid flushing ip addresses when setting Static IPv4 addresses if the IPs are the expected ones. Signed-off-by: Marcello Seri --- networkd/network_server.ml | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 000c6438d..7fa529309 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -175,8 +175,13 @@ module Interface = struct | Static4 addrs -> if Dhclient.is_running name then ignore (Dhclient.stop name); - Ip.flush_ip_addr name; - List.iter (Ip.set_ip_addr name) addrs + (* the function is meant to be idempotent and we + * want to avoid CA-239919 *) + let cur_addrs = Ip.get_ipv4 name in + let rm_addrs = List.set_difference cur_addrs addrs in + let add_addrs = List.set_difference addrs cur_addrs in + List.iter (Ip.del_ip_addr name) rm_addrs; + List.iter (Ip.set_ip_addr name) add_addrs ) () let get_ipv4_gateway _ dbg ~name = From 6456a6f9752f247610284748245d4829e8a42ab6 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Mon, 23 Jan 2017 12:07:44 +0000 Subject: [PATCH 133/260] CA-239919: avoid flushing Static IPv6 addresses as well Signed-off-by: Marcello Seri --- networkd/network_server.ml | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 7fa529309..21755b5b9 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -248,9 +248,18 @@ module Interface = struct if Dhclient.is_running ~ipv6:true name then ignore (Dhclient.stop ~ipv6:true name); Sysctl.set_ipv6_autoconf name false; - Ip.flush_ip_addr ~ipv6:true name; - Ip.set_ipv6_link_local_addr name; - List.iter (Ip.set_ip_addr name) addrs + (* add the link_local and clean the old one only when needed *) + let cur_addrs = + let addrs = Ip.get_ipv6 name in + let maybe_link_local = Ip.split_addr (Ip.get_ipv6_link_local_addr name) in + match maybe_link_local with + | Some addr -> List.setify (addr :: addrs) + | None -> addrs + in + let rm_addrs = List.set_difference cur_addrs addrs in + let add_addrs = List.set_difference addrs cur_addrs in + List.iter (Ip.del_ip_addr name) rm_addrs; + List.iter (Ip.set_ip_addr name) add_addrs ) () let get_ipv6_gateway _ dbg ~name = From c6a654e2afe706ec8961c6b155f00d5369d82853 Mon Sep 17 00:00:00 2001 From: Sharad Yadav Date: Thu, 2 Feb 2017 16:23:48 +0000 Subject: [PATCH 134/260] CA-223676: Add function `get_physical_interfaces` to networkd This function will provide the physical interfaces underneath the bridge. Bridge can be on: 1) Physical interface. 2) VLAN on physical interface. 3) On a bond. 4) VLAN on a bond. Signed-off-by: Sharad Yadav --- lib/network_utils.ml | 5 +++++ networkd/network_server.ml | 31 ++++++++++++++++++++++++++----- 2 files changed, 31 insertions(+), 5 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index eb7b1278e..f916d005f 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -776,6 +776,11 @@ module Ovs = struct debug "bridge_to_vlan: %s" (Printexc.to_string e); None + let get_real_bridge name = + match bridge_to_vlan name with + | Some (parent, vlan) -> parent + | None -> name + let get_bond_link_status name = try let raw = appctl ["bond/show"; name] in diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 21755b5b9..d3fa6e155 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -788,11 +788,7 @@ module Bridge = struct match !backend_kind with | Openvswitch -> ignore (Ovs.create_port ~internal:true name bridge); - let real_bridge = - match Ovs.bridge_to_vlan bridge with - | Some (parent, _) -> parent - | None -> bridge - in + let real_bridge = Ovs.get_real_bridge bridge in Ovs.mod_port real_bridge name "no-flood"; Interface.bring_up () dbg ~name | Bridge -> @@ -844,6 +840,31 @@ module Bridge = struct Sysfs.bridge_to_interfaces name ) () + let get_physical_interfaces _ dbg ~name = + Debug.with_thread_associated dbg (fun () -> + match !backend_kind with + | Openvswitch -> + Ovs.get_real_bridge name + |> Ovs.bridge_to_interfaces + |> List.filter (Sysfs.is_physical) + + | Bridge -> + let ifaces = Sysfs.bridge_to_interfaces name in + let vlan_ifaces = List.filter (fun (bridge, _, _) -> List.mem bridge ifaces) (Proc.get_vlans ()) in + let bond_ifaces = List.filter (fun iface -> Linux_bonding.is_bond_device iface) ifaces in + let physical_ifaces = List.filter (fun iface -> Sysfs.is_physical iface) ifaces in + if vlan_ifaces <> [] then + let _, _, parent = List.hd vlan_ifaces in + if Linux_bonding.is_bond_device parent then + Linux_bonding.get_bond_slaves parent + else + [parent] + else if bond_ifaces <> [] then + Linux_bonding.get_bond_slaves (List.hd bond_ifaces) + else + physical_ifaces + ) () + let get_fail_mode _ dbg ~name = Debug.with_thread_associated dbg (fun () -> match !backend_kind with From 234709286f53fc919c68caeaf47d92bd5f0de577 Mon Sep 17 00:00:00 2001 From: Euan Harris Date: Tue, 25 Apr 2017 14:00:21 +0000 Subject: [PATCH 135/260] CA-250444: Always flush addresses when switching from DHCP to static dhclient now sets limited address lifetimes on DHCP-allocated addresses: 7: xenbr0: mtu 1500 qdisc noqueue state UNKNOWN qlen 1 link/ether 18:a9:9b:23:e8:af brd ff:ff:ff:ff:ff:ff inet 10.71.152.106/21 brd 10.71.159.255 scope global dynamic xenbr0 valid_lft 16017sec preferred_lft 16017sec If we switch from DHCP to static addressing using the same IP address, xcp-networkd will see that the address is already assigned to the interface and will not update it. Without dhclient updating the lifetime timer, the address will eventually time out and the kernel will remove it. To avoid this problem, we now flush all an interface's addresses when switching from DHCP to static addressing, then re-add the static address. This results in the lifetime being set to 'forever': 7: xenbr0: mtu 1500 qdisc noqueue state UNKNOWN qlen 1 link/ether 18:a9:9b:23:e8:af brd ff:ff:ff:ff:ff:ff inet 10.71.152.106/21 brd 10.71.159.255 scope global xenbr0 valid_lft forever preferred_lft forever Signed-off-by: Euan Harris --- networkd/network_server.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index d3fa6e155..243baa7d0 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -173,8 +173,10 @@ module Interface = struct let options = gateway @ dns in Dhclient.ensure_running name options | Static4 addrs -> - if Dhclient.is_running name then + if Dhclient.is_running name then begin ignore (Dhclient.stop name); + Ip.flush_ip_addr name + end; (* the function is meant to be idempotent and we * want to avoid CA-239919 *) let cur_addrs = Ip.get_ipv4 name in From 2eeb50c3c9871e67c53501f4dc2fa3f23a6eda21 Mon Sep 17 00:00:00 2001 From: Thomas Sanders Date: Thu, 11 May 2017 18:47:20 +0100 Subject: [PATCH 136/260] CP-22034: read PIF speed & duplex from sysfs Sisyphus can tell us these details nowadays, so we can read them from the relevant files rather than going through the C bindings. The existing C bindings cannot cope with speeds such as 50 Gbits/second and higher. Therefore this commit removes the get_status functions from the C stub and removes the Bindings module that uses it, and adds a replacement get_status function in the Sysfs module; it returns the same (speed, duplex) pair as the old function. Signed-off-by: Thomas Sanders --- lib/link_stubs.c | 39 +------------------------ lib/network_utils.ml | 46 ++++++++---------------------- networkd/network_monitor_thread.ml | 4 +-- 3 files changed, 15 insertions(+), 74 deletions(-) diff --git a/lib/link_stubs.c b/lib/link_stubs.c index 45f4ea583..f75f712f9 100644 --- a/lib/link_stubs.c +++ b/lib/link_stubs.c @@ -137,43 +137,6 @@ struct ethtool_cmd { uint32_t reserved[4]; }; -value stub_link_get_status(value fd, value dev) -{ - CAMLparam2(fd, dev); - CAMLlocal1(ret); - struct ifreq ifr; - struct ethtool_cmd ecmd; - int err, speed, duplex; - - SET_IFREQ(ifr, String_val(dev)); - ecmd.cmd = ETHTOOL_GSET; - ifr.ifr_data = (caddr_t) &ecmd; - err = ioctl(Int_val(fd), SIOCETHTOOL, &ifr); - CHECK_IOCTL(err, "get ethtool"); - - /* CA-24610: apparently speeds can be other values eg 2500 */ - speed = ecmd.speed; - - switch (ecmd.duplex) { - case 0: duplex = 1; break; - case 1: duplex = 2; break; - default: duplex = 0; - } - - ret = caml_alloc_tuple(2); - Store_field(ret, 0, Val_int(speed)); - Store_field(ret, 1, Val_int(duplex)); - - CAMLreturn(ret); -} #else -value stub_link_get_status(value fd, value dev) -{ - CAMLparam2(fd, dev); - CAMLlocal1(ret); - ret = caml_alloc_tuple(2); - Store_field(ret, 0, Val_int(0)); /* unknown speed */ - Store_field(ret, 1, Val_int(0)); /* unknown duplex */ - CAMLreturn(ret); -} +/* nothing here at present */ #endif diff --git a/lib/network_utils.ml b/lib/network_utils.ml index f916d005f..b750482db 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -179,6 +179,18 @@ module Sysfs = struct let get_all_bridges () = let ifaces = list () in List.filter (fun name -> Sys.file_exists (getpath name "bridge")) ifaces + + (** Returns (speed, duplex) for a given network interface: int megabits/s, Duplex. + * The units of speed are specified in pif_record in xen-api/xapi/records.ml. + * Note: these data are present in sysfs from kernel 2.6.33. *) + let get_status name = + let speed = getpath name "speed" + |> (fun p -> try (read_one_line p |> int_of_string) with _ -> 0) + in + let duplex = getpath name "duplex" + |> (fun p -> try read_one_line p |> duplex_of_string with _ -> Duplex_unknown) + in (speed, duplex) + end module Ip = struct @@ -1093,37 +1105,3 @@ module Ethtool = struct if options <> [] then ignore (call ~log:true ("-K" :: name :: (List.concat (List.map (fun (k, v) -> [k; v]) options)))) end - -module Bindings = struct - let control_socket () = - try - Unix.socket Unix.PF_INET Unix.SOCK_DGRAM 0 - with - exn -> - try - Unix.socket Unix.PF_UNIX Unix.SOCK_DGRAM 0 - with - exn -> - Unix.socket Unix.PF_INET6 Unix.SOCK_DGRAM 0 - - let with_fd f = - let fd = control_socket () in - let r = begin try - f fd - with - exn -> - Unix.close fd; - raise exn - end in - Unix.close fd; - r - - external _get_status : Unix.file_descr -> string -> int * duplex = "stub_link_get_status" - - (** Returns speed and duplex for a given network interface. - * Note: from kernel 2.6.33, this information is also present in sysfs. *) - let get_status name = - try - with_fd (fun fd -> _get_status fd name) - with _ -> raise (Read_error "stub_link_get_status") -end diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index 19ce16f75..13d9002bf 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -188,7 +188,7 @@ let rec monitor dbg () = let carrier = Sysfs.get_carrier dev in let speed, duplex = if carrier then - try Bindings.get_status dev with _ -> (0, Duplex_unknown) + Sysfs.get_status dev else (0, Duplex_unknown) in @@ -209,7 +209,7 @@ let rec monitor dbg () = List.fold_left (fun (speed, duplex) info -> try if info.active then - let speed', duplex' = Bindings.get_status info.slave in + let speed', duplex' = Sysfs.get_status info.slave in speed + speed', combine_duplex (duplex, duplex') else speed, duplex From 062055bd569c5ade85b2e72306239ba4981182dd Mon Sep 17 00:00:00 2001 From: Thomas Sanders Date: Fri, 12 May 2017 11:55:51 +0100 Subject: [PATCH 137/260] CP-22034: Remove the C file completely. It is no longer needed, so remove the file and the _oasis line that refers to it. Then re-run "oasis setup" to regenerate _tags, setup.ml and myocamlbuild.ml Signed-off-by: Thomas Sanders --- _oasis | 2 - _tags | 190 ++--- lib/link_stubs.c | 142 ---- myocamlbuild.ml | 390 +++------ setup.ml | 2110 +++++++++++----------------------------------- 5 files changed, 720 insertions(+), 2114 deletions(-) delete mode 100644 lib/link_stubs.c diff --git a/_oasis b/_oasis index 4266fa604..5d25036b3 100644 --- a/_oasis +++ b/_oasis @@ -28,8 +28,6 @@ Library networklibs xcp-inventory, xcp.network, systemd - CSources: link_stubs.c, netdev.h - CCOpt: -Wno-unused-function -g -ggdb Executable xcp_networkd CompiledObject: best diff --git a/_tags b/_tags index 53f061a82..cc62a4d35 100644 --- a/_tags +++ b/_tags @@ -1,9 +1,8 @@ # OASIS_START -# DO NOT EDIT (digest: 6789724751e66864fb1299d08f339eb0) -# Ignore VCS directories, you can use the same kind of rule outside -# OASIS_START/STOP if you want to exclude directories that contains +# DO NOT EDIT (digest: 2e20ef321d942788d2374e5ecfec8300) +# 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 -true: annot, bin_annot <**/.svn>: -traverse <**/.svn>: not_hygienic ".bzr": -traverse @@ -18,125 +17,116 @@ true: annot, bin_annot "profiling/profiling.cmxs": use_profiling # Library networklibs "lib/networklibs.cmxs": use_networklibs -: oasis_library_networklibs_ccopt -"lib/link_stubs.c": oasis_library_networklibs_ccopt -: use_libnetworklibs_stubs -: pkg_forkexec -: pkg_rpclib -: pkg_stdext -: pkg_systemd -: pkg_threads -: pkg_xcp-inventory -: pkg_xcp.network -"lib/link_stubs.c": pkg_forkexec -"lib/link_stubs.c": pkg_rpclib -"lib/link_stubs.c": pkg_stdext -"lib/link_stubs.c": pkg_systemd -"lib/link_stubs.c": pkg_threads -"lib/link_stubs.c": pkg_xcp-inventory -"lib/link_stubs.c": pkg_xcp.network +: oasis_library_networklibs_ccopt +: pkg_stdext +: pkg_xcp.network +: pkg_threads +: pkg_rpclib +: pkg_forkexec +: pkg_xcp-inventory +: pkg_systemd # Executable xcp_networkd -: pkg_forkexec -: pkg_netlink -: pkg_rpclib -: pkg_rpclib.unix +: use_profiling +: use_networklibs : pkg_stdext -: pkg_systemd -: pkg_threads : pkg_xcp -: pkg_xcp-inventory : pkg_xcp.network +: pkg_threads +: pkg_rpclib +: pkg_rpclib.unix +: pkg_forkexec +: pkg_xcp-inventory : pkg_xen-api-client -: use_networklibs -: use_profiling -: pkg_forkexec -: pkg_netlink -: pkg_rpclib -: pkg_rpclib.unix -: pkg_stdext -: pkg_systemd -: pkg_threads -: pkg_xcp -: pkg_xcp-inventory -: pkg_xcp.network -: pkg_xen-api-client -: use_networklibs -: use_profiling +: pkg_netlink +: pkg_systemd +: use_profiling +: use_networklibs +: pkg_stdext +: pkg_xcp +: pkg_xcp.network +: pkg_threads +: pkg_rpclib +: pkg_rpclib.unix +: pkg_forkexec +: pkg_xcp-inventory +: pkg_xen-api-client +: pkg_netlink +: pkg_systemd : custom # Executable networkd_db -: pkg_forkexec -: pkg_rpclib +: use_profiling +: use_networklibs : pkg_stdext -: pkg_systemd +: pkg_xcp.network : pkg_threads +: pkg_rpclib +: pkg_forkexec : pkg_xcp-inventory -: pkg_xcp.network -: use_networklibs -: use_profiling -: pkg_forkexec -: pkg_rpclib -: pkg_stdext -: pkg_systemd -: pkg_threads -: pkg_xcp-inventory -: pkg_xcp.network -: use_networklibs -: use_profiling +: pkg_systemd +: use_profiling +: use_networklibs +: pkg_stdext +: pkg_xcp.network +: pkg_threads +: pkg_rpclib +: pkg_forkexec +: pkg_xcp-inventory +: pkg_systemd : custom # Executable network_test -: pkg_forkexec -: pkg_oUnit -: pkg_rpclib +: use_profiling +: use_networklibs : pkg_stdext -: pkg_systemd -: pkg_threads +: pkg_xcp.network +: pkg_oUnit : pkg_xapi-test-utils +: pkg_threads +: pkg_rpclib +: pkg_forkexec : pkg_xcp-inventory -: pkg_xcp.network -: use_networklibs -: use_profiling -: pkg_oUnit -: pkg_xapi-test-utils -: use_profiling +: pkg_systemd +: use_profiling +: pkg_oUnit +: pkg_xapi-test-utils # Executable cli +: use_profiling +: use_networklibs : pkg_cmdliner -: pkg_forkexec -: pkg_rpclib : pkg_stdext -: pkg_systemd -: pkg_threads : pkg_xcp -: pkg_xcp-inventory : pkg_xcp.network -: use_networklibs -: use_profiling -: pkg_cmdliner -: pkg_forkexec -: pkg_rpclib -: pkg_stdext -: pkg_systemd -: pkg_threads -: pkg_xcp -: pkg_xcp-inventory -: pkg_xcp.network -: use_networklibs -: use_profiling +: pkg_threads +: pkg_rpclib +: pkg_forkexec +: pkg_xcp-inventory +: pkg_systemd +: use_profiling +: use_networklibs +: pkg_cmdliner +: pkg_stdext +: pkg_xcp +: pkg_xcp.network +: pkg_threads +: pkg_rpclib +: pkg_forkexec +: pkg_xcp-inventory +: pkg_systemd # Executable jsonrpc_dummy -: pkg_forkexec -: pkg_rpclib +: use_networklibs : pkg_stdext -: pkg_systemd +: pkg_xcp.network : pkg_threads +: pkg_rpclib +: pkg_forkexec : pkg_xcp-inventory -: pkg_xcp.network -: use_networklibs -: pkg_forkexec -: pkg_rpclib -: pkg_stdext -: pkg_systemd -: pkg_threads -: pkg_xcp-inventory -: pkg_xcp.network -: use_networklibs +: pkg_systemd +: use_networklibs +: pkg_stdext +: pkg_xcp.network +: pkg_threads +: pkg_rpclib +: pkg_forkexec +: pkg_xcp-inventory +: pkg_systemd # OASIS_STOP diff --git a/lib/link_stubs.c b/lib/link_stubs.c deleted file mode 100644 index f75f712f9..000000000 --- a/lib/link_stubs.c +++ /dev/null @@ -1,142 +0,0 @@ -/* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program 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. See the - * GNU Lesser General Public License for more details. - */ -/* - */ - -#include "netdev.h" - -#include -#include -#include -#include -#include -#include - -#define SET_IFREQ(ifreq, devname) \ - strncpy(ifreq.ifr_name, devname, IFNAMSIZ) - -static int link_change_flags(int fd, char *name, - unsigned int flags, unsigned int mask) -{ - struct ifreq ifr; - int ret; - - SET_IFREQ(ifr, name); - ret = ioctl(fd, SIOCGIFFLAGS, &ifr); - if (ret < 0) - return ret; - if ((ifr.ifr_flags ^ flags) & mask) { - ifr.ifr_flags &= ~mask; - ifr.ifr_flags |= mask & flags; - ret = ioctl(fd, SIOCSIFFLAGS, &ifr); - } - return ret; -} - -static int link_change_name(int fd, char *name, char *newname) -{ - struct ifreq ifr; - int ret; - - SET_IFREQ(ifr, name); - strncpy(ifr.ifr_newname, newname, IFNAMSIZ); - ret = ioctl(fd, SIOCSIFNAME, &ifr); - return ret; -} - -value stub_link_up(value fd, value dev) -{ - CAMLparam2(fd, dev); - int err; - err = link_change_flags(Int_val(fd), String_val(dev), IFF_UP, IFF_UP); - CHECK_IOCTL(err, "link up"); - CAMLreturn(Val_unit); -} - -value stub_link_is_up(value fd, value dev) -{ - CAMLparam2(fd, dev); - struct ifreq ifr; - int err; - - SET_IFREQ(ifr, String_val(dev)); - err = ioctl(Int_val(fd), SIOCGIFFLAGS, &ifr); - CHECK_IOCTL(err, "link_is_up"); - CAMLreturn(Val_bool (ifr.ifr_flags & IFF_UP)); -} - -value stub_link_down(value fd, value dev) -{ - CAMLparam2(fd, dev); - int err; - err = link_change_flags(Int_val(fd), String_val(dev), 0, IFF_UP); - CHECK_IOCTL(err, "link down"); - - CAMLreturn(Val_unit); -} - -value stub_link_change_name(value fd, value dev, value newname) -{ - CAMLparam3(fd, dev, newname); - int err; - - err = link_change_name(Int_val(fd), - String_val(dev), String_val(newname)); - CHECK_IOCTL(err, "link change name"); - CAMLreturn(Val_unit); -} - -value stub_link_multicast(value fd, value dev, value v) -{ - CAMLparam3(fd, dev, v); - int err; - err = link_change_flags(Int_val(fd), String_val(dev), - ((Bool_val(v)) ? IFF_MULTICAST : 0), IFF_MULTICAST); - CHECK_IOCTL(err, "link multicast"); - CAMLreturn(Val_unit); -} - -value stub_link_arp(value fd, value dev, value v) -{ - CAMLparam3(fd, dev, v); - int err; - err = link_change_flags(Int_val(fd), String_val(dev), - ((Bool_val(v)) ? 0 : IFF_NOARP), IFF_NOARP); - CHECK_IOCTL(err, "link arp"); - CAMLreturn(Val_unit); -} - -#ifdef SIOCETHTOOL -#define ETHTOOL_GSET 0x00000001 /* Get settings. */ - -#include -/* copied from linux/ethtool.h and made compilable with userspace types */ -struct ethtool_cmd { - uint32_t cmd; - uint32_t supported; /* Features this interface supports */ - uint32_t advertising; /* Features this interface advertises */ - uint16_t speed; /* The forced speed, 10Mb, 100Mb, gigabit */ - uint8_t duplex; /* Duplex, half or full */ - uint8_t port; /* Which connector port */ - uint8_t phy_address; - uint8_t transceiver; /* Which transceiver to use */ - uint8_t autoneg; /* Enable or disable autonegotiation */ - uint32_t maxtxpkt; /* Tx pkts before generating tx int */ - uint32_t maxrxpkt; /* Rx pkts before generating rx int */ - uint32_t reserved[4]; -}; - -#else -/* nothing here at present */ -#endif diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 8184a6b32..d1e7bacbf 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,49 +1,38 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: cda025dade953b8f1e9b18cca6f3e0fb) *) +(* DO NOT EDIT (digest: ab6e95fe4216607ba5333bd62a013f84) *) module OASISGettext = struct -(* # 22 "src/oasis/OASISGettext.ml" *) - +(* # 21 "src/oasis/OASISGettext.ml" *) let ns_ str = str - let s_ str = str - - let f_ (str: ('a, 'b, 'c, 'd) format4) = + let f_ (str : ('a, 'b, 'c, 'd) format4) = str - let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" - let init = [] - end module OASISExpr = struct -(* # 22 "src/oasis/OASISExpr.ml" *) - - +(* # 21 "src/oasis/OASISExpr.ml" *) open OASISGettext + type test = string - type test = string - - - type flag = string - + type flag = string type t = | EBool of bool @@ -52,11 +41,9 @@ module OASISExpr = struct | EOr of t * t | EFlag of flag | ETest of test * string + - - - type 'a choices = (t * 'a) list - + type 'a choices = (t * 'a) list let eval var_get t = let rec eval' = @@ -88,7 +75,6 @@ module OASISExpr = struct in eval' t - let choose ?printer ?name var_get lst = let rec choose_aux = function @@ -125,27 +111,22 @@ module OASISExpr = struct in choose_aux (List.rev lst) - end -# 132 "myocamlbuild.ml" +# 117 "myocamlbuild.ml" module BaseEnvLight = struct -(* # 22 "src/base/BaseEnvLight.ml" *) - +(* # 21 "src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) - type t = string MapString.t - let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" - let load ?(allow_empty=false) ?(filename=default_filename) () = if Sys.file_exists filename then begin @@ -203,29 +184,26 @@ module BaseEnvLight = struct filename) end - - let rec var_expand str env = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) env - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff - - let var_get name env = - var_expand (MapString.find name env) env - + let rec var_expand str = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + in + var_expand (MapString.find name env) let var_choose lst env = OASISExpr.choose @@ -234,165 +212,88 @@ module BaseEnvLight = struct end -# 237 "myocamlbuild.ml" +# 215 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct -(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) +(* # 21 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) - - (** OCamlbuild extension, copied from + (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild * by N. Pouillard and others * * Updated on 2009/02/28 * - * Modified by Sylvain Le Gall + * Modified by Sylvain Le Gall *) open Ocamlbuild_plugin - type conf = - { no_automatic_syntax: bool; - } - (* these functions are not really officially exported *) - let run_and_read = + let run_and_read = Ocamlbuild_pack.My_unix.run_and_read - - let blank_sep_strings = + let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings - - let exec_from_conf exec = - let exec = - let env_filename = Pathname.basename BaseEnvLight.default_filename in - let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in - try - BaseEnvLight.var_get exec env - with Not_found -> - Printf.eprintf "W: Cannot get variable %s\n" exec; - exec - in - let fix_win32 str = - if Sys.os_type = "Win32" then begin - let buff = Buffer.create (String.length str) in - (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. - *) - String.iter - (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) - str; - Buffer.contents buff - end else begin - str - end - in - fix_win32 exec - 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' - let before_space s = try String.before s (String.index s ' ') with Not_found -> s - (* ocamlfind command *) - let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] - - (* This lists all supported packages. *) + (* this lists all supported packages *) let find_packages () = - List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) + List.map before_space (split_nl & run_and_read "ocamlfind list") - - (* Mock to list available syntaxes. *) + (* this is supposed to list available syntaxes, but I don't know how to do it. *) let find_syntaxes () = ["camlp4o"; "camlp4r"] + (* ocamlfind command *) + let ocamlfind x = S[A"ocamlfind"; x] - let well_known_syntax = [ - "camlp4.quotations.o"; - "camlp4.quotations.r"; - "camlp4.exceptiontracer"; - "camlp4.extend"; - "camlp4.foldgenerator"; - "camlp4.listcomprehension"; - "camlp4.locationstripper"; - "camlp4.macro"; - "camlp4.mapgenerator"; - "camlp4.metagenerator"; - "camlp4.profiler"; - "camlp4.tracer" - ] - - - let dispatch conf = + let dispatch = function - | After_options -> - (* By using Before_options one let command line options have an higher - * priority on the contrary using After_options will guarantee to have - * the higher priority override default commands by ocamlfind ones *) + | Before_options -> + (* by using Before_options one let command line options have an higher priority *) + (* on the contrary using After_options will guarantee to have the higher priority *) + (* override default commands by ocamlfind ones *) Options.ocamlc := ocamlfind & A"ocamlc"; Options.ocamlopt := ocamlfind & A"ocamlopt"; Options.ocamldep := ocamlfind & A"ocamldep"; Options.ocamldoc := ocamlfind & A"ocamldoc"; - Options.ocamlmktop := ocamlfind & A"ocamlmktop"; - Options.ocamlmklib := ocamlfind & A"ocamlmklib" - + Options.ocamlmktop := ocamlfind & A"ocamlmktop" + | After_rules -> - - (* When one link an OCaml library/binary/package, one should use - * -linkpkg *) + + (* When one link an OCaml library/binary/package, one should use -linkpkg *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; - - if not (conf.no_automatic_syntax) then begin - (* 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 - (* TODO: consider how to really choose camlp4o or camlp4r. *) - let syn_args = [A"-syntax"; A "camlp4o"] in - let (args, pargs) = - (* Heuristic to identify syntax extensions: whether they end in - ".syntax"; some might not. - *) - if Filename.check_suffix pkg "syntax" || - List.mem pkg well_known_syntax then - (syn_args @ base_args, syn_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; - - (* TODO: Check if this is allowed for OCaml < 3.12.1 *) - flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; - end - (find_packages ()); - end; + + (* 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]; + end + (find_packages ()); (* Like -package but for extensions syntax. Morover -syntax is useless * when linking. *) @@ -400,34 +301,29 @@ module MyOCamlbuildFindlib = struct flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & - S[A"-syntax"; A syntax]; + flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; end (find_syntaxes ()); (* The default "thread" tag is not compatible with ocamlfind. * Indeed, the default rules add the "threads.cma" or "threads.cmxa" * options when using this tag. When using the "-linkpkg" option with * ocamlfind, this module will then be added twice on the command line. - * + * * To solve this, one approach is to add the "-thread" option when using * the "threads" package using the previous plugin. *) flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); - flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); - flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); - flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); - flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); - flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); + flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]) - | _ -> + | _ -> () + end module MyOCamlbuildBase = struct -(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) - +(* # 21 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall @@ -435,61 +331,51 @@ module MyOCamlbuildBase = struct - - open Ocamlbuild_plugin module OC = Ocamlbuild_pack.Ocaml_compiler + type dir = string + type file = string + type name = string + type tag = string - type dir = string - type file = string - type name = string - type tag = string - - -(* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) - +(* # 56 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { - lib_ocaml: (name * dir list * string list) list; - lib_c: (name * dir * file list) list; + lib_ocaml: (name * dir list) list; + lib_c: (name * dir * file list) list; flags: (tag list * (spec OASISExpr.choices)) list; (* Replace the 'dir: include' from _tags by a precise interdepends in * directory. *) - includes: (dir * dir list) list; - } - + includes: (dir * dir list) list; + } let env_filename = - Pathname.basename + Pathname.basename BaseEnvLight.default_filename - let dispatch_combine lst = fun e -> - List.iter + List.iter (fun dispatch -> dispatch e) - lst - + lst let tag_libstubs nm = "use_lib"^nm^"_stubs" - let nm_libstubs nm = nm^"_stubs" - - let dispatch t e = - let env = - BaseEnvLight.load - ~filename:env_filename + let dispatch t e = + let env = + BaseEnvLight.load + ~filename:env_filename ~allow_empty:true () in - match e with + match e with | Before_options -> let no_trailing_dot s = if String.length s >= 1 && s.[0] = '.' then @@ -499,44 +385,35 @@ module MyOCamlbuildBase = struct in List.iter (fun (opt, var) -> - try + try opt := no_trailing_dot (BaseEnvLight.var_get var env) with Not_found -> - Printf.eprintf "W: Cannot get variable %s\n" var) + Printf.eprintf "W: Cannot get variable %s" var) [ Options.ext_obj, "ext_obj"; Options.ext_lib, "ext_lib"; Options.ext_dll, "ext_dll"; ] - | After_rules -> + | After_rules -> (* Declare OCaml libraries *) - List.iter + List.iter (function - | nm, [], intf_modules -> - ocaml_lib nm; - let cmis = - List.map (fun m -> (String.uncapitalize m) ^ ".cmi") - intf_modules in - dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis - | nm, dir :: tl, intf_modules -> + | nm, [] -> + ocaml_lib nm + | nm, dir :: tl -> ocaml_lib ~dir:dir (dir^"/"^nm); - List.iter - (fun dir -> + List.iter + (fun dir -> List.iter (fun str -> flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) ["compile"; "infer_interface"; "doc"]) - tl; - let cmis = - List.map (fun m -> dir^"/"^(String.uncapitalize m)^".cmi") - intf_modules in - dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] - cmis) + tl) t.lib_ocaml; (* Declare directories dependencies, replace "include" in _tags. *) - List.iter + List.iter (fun (dir, include_dirs) -> Pathname.define_context dir include_dirs) t.includes; @@ -551,27 +428,26 @@ module MyOCamlbuildBase = struct flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); - + flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); (* When ocaml link something that use the C library, then one need that file to be up to date. - This holds both for programs and for libraries. *) - dep ["link"; "ocaml"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + dep ["link"; "ocaml"; "program"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; - dep ["compile"; "ocaml"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + dep ["compile"; "ocaml"; "program"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; (* TODO: be more specific about what depends on headers *) (* Depends on .h files *) - dep ["compile"; "c"] + dep ["compile"; "c"] headers; (* Setup search path for lib *) - flag ["link"; "ocaml"; "use_"^lib] + flag ["link"; "ocaml"; "use_"^lib] (S[A"-I"; P(dir)]); ) t.lib_c; @@ -579,37 +455,31 @@ module MyOCamlbuildBase = struct (* Add flags *) List.iter (fun (tags, cond_specs) -> - let spec = BaseEnvLight.var_choose cond_specs env in - let rec eval_specs = - function - | S lst -> S (List.map eval_specs lst) - | A str -> A (BaseEnvLight.var_expand str env) - | spec -> spec + let spec = + BaseEnvLight.var_choose cond_specs env in - flag tags & (eval_specs spec)) + flag tags & spec) t.flags - | _ -> + | _ -> () - - let dispatch_default conf t = - dispatch_combine + let dispatch_default t = + dispatch_combine [ dispatch t; - MyOCamlbuildFindlib.dispatch conf; + MyOCamlbuildFindlib.dispatch; ] - end -# 606 "myocamlbuild.ml" +# 476 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { MyOCamlbuildBase.lib_ocaml = - [("profiling", ["profiling"], []); ("networklibs", ["lib"], [])]; - lib_c = [("networklibs", "lib", ["lib/netdev.h"])]; + [("profiling", ["profiling"]); ("networklibs", ["lib"])]; + lib_c = []; flags = [ (["oasis_library_networklibs_ccopt"; "compile"], @@ -632,14 +502,12 @@ let package_default = ("networkd_db", ["lib"; "profiling"]); ("networkd", ["lib"; "profiling"]); ("cli", ["lib"; "profiling"]) - ] - } + ]; + } ;; -let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} - -let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; +let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; -# 644 "myocamlbuild.ml" +# 512 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/setup.ml b/setup.ml index b17cb6736..50bd3a945 100644 --- a/setup.ml +++ b/setup.ml @@ -1,58 +1,48 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: ee3c028836cb8490a074295e123698ad) *) +(* DO NOT EDIT (digest: 705e1ead1104847e0c184cf5fad79198) *) (* - Regenerated by OASIS v0.4.5 + 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 -(* # 22 "src/oasis/OASISGettext.ml" *) - +(* # 21 "src/oasis/OASISGettext.ml" *) let ns_ str = str - let s_ str = str - - let f_ (str: ('a, 'b, 'c, 'd) format4) = + let f_ (str : ('a, 'b, 'c, 'd) format4) = str - let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" - let init = [] - end module OASISContext = struct -(* # 22 "src/oasis/OASISContext.ml" *) - +(* # 21 "src/oasis/OASISContext.ml" *) open OASISGettext - type level = [ `Debug | `Info | `Warning | `Error] - type t = { - (* TODO: replace this by a proplist. *) quiet: bool; info: bool; debug: bool; @@ -61,7 +51,6 @@ module OASISContext = struct printf: level -> string -> unit; } - let printf lvl str = let beg = match lvl with @@ -72,7 +61,6 @@ module OASISContext = struct in prerr_endline (beg^str) - let default = ref { @@ -84,50 +72,37 @@ module OASISContext = struct printf = printf; } - let quiet = {!default with quiet = true} - let fspecs () = - (* TODO: don't act on default. *) - let ignore_plugins = ref false in + let args () = ["-quiet", Arg.Unit (fun () -> default := {!default with quiet = true}), - s_ " Run quietly"; + (s_ " Run quietly"); "-info", Arg.Unit (fun () -> default := {!default with info = true}), - s_ " Display information message"; + (s_ " Display information message"); "-debug", Arg.Unit (fun () -> default := {!default with debug = true}), - s_ " Output debug message"; - - "-ignore-plugins", - Arg.Set ignore_plugins, - s_ " Ignore plugin's field."; - - "-C", - (* TODO: remove this chdir. *) - Arg.String (fun str -> Sys.chdir str), - s_ "dir Change directory before running."], - fun () -> {!default with ignore_plugins = !ignore_plugins} + (s_ " Output debug message")] end module OASISString = struct -(* # 22 "src/oasis/OASISString.ml" *) +(* # 1 "src/oasis/OASISString.ml" *) - (** Various string utilities. + (** Various string utilities. + Mostly inspired by extlib and batteries ExtString and BatString libraries. @author Sylvain Le Gall *) - let nsplitf str f = if str = "" then [] @@ -148,18 +123,16 @@ module OASISString = struct push (); List.rev !lst - (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the separator. *) let nsplit str c = nsplitf str ((=) c) - let find ~what ?(offset=0) str = let what_idx = ref 0 in - let str_idx = ref offset in - while !str_idx < String.length str && + let str_idx = ref offset in + while !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx @@ -169,18 +142,16 @@ module OASISString = struct done; if !what_idx <> String.length what then raise Not_found - else + else !str_idx - !what_idx - - let sub_start str len = + let sub_start str len = let str_len = String.length str in if len >= str_len then "" else String.sub str len (str_len - len) - let sub_end ?(offset=0) str len = let str_len = String.length str in if len >= str_len then @@ -188,13 +159,12 @@ module OASISString = struct else String.sub str 0 (str_len - len) - let starts_with ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in let ok = ref true in while !ok && - !str_idx < String.length str && + !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx @@ -204,23 +174,21 @@ module OASISString = struct done; if !what_idx = String.length what then true - else + else false - let strip_starts_with ~what str = if starts_with ~what str then sub_start str (String.length what) else raise Not_found - let ends_with ~what ?(offset=0) str = let what_idx = ref ((String.length what) - 1) in let str_idx = ref ((String.length str) - 1) in let ok = ref true in while !ok && - offset <= !str_idx && + offset <= !str_idx && 0 <= !what_idx do if str.[!str_idx] = what.[!what_idx] then decr what_idx @@ -230,94 +198,53 @@ module OASISString = struct done; if !what_idx = -1 then true - else + else false - let strip_ends_with ~what str = if ends_with ~what str then sub_end str (String.length what) else raise Not_found - let replace_chars f s = - let buf = Buffer.create (String.length s) in - String.iter (fun c -> Buffer.add_char buf (f c)) s; - Buffer.contents buf - + let buf = String.make (String.length s) 'X' in + for i = 0 to String.length s - 1 do + buf.[i] <- f s.[i] + done; + buf end module OASISUtils = struct -(* # 22 "src/oasis/OASISUtils.ml" *) - +(* # 21 "src/oasis/OASISUtils.ml" *) open OASISGettext + module MapString = Map.Make(String) - module MapExt = - struct - module type S = - sig - include Map.S - val add_list: 'a t -> (key * 'a) list -> 'a t - val of_list: (key * 'a) list -> 'a t - val to_list: 'a t -> (key * 'a) list - end - - module Make (Ord: Map.OrderedType) = - struct - include Map.Make(Ord) - - let rec add_list t = - function - | (k, v) :: tl -> add_list (add k v t) tl - | [] -> t - - let of_list lst = add_list empty lst - - let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] - end - end - - - module MapString = MapExt.Make(String) - - - module SetExt = - struct - module type S = - sig - include Set.S - val add_list: t -> elt list -> t - val of_list: elt list -> t - val to_list: t -> elt list - end - - module Make (Ord: Set.OrderedType) = - struct - include Set.Make(Ord) - - let rec add_list t = - function - | e :: tl -> add_list (add e t) tl - | [] -> t + let map_string_of_assoc assoc = + List.fold_left + (fun acc (k, v) -> MapString.add k v acc) + MapString.empty + assoc - let of_list lst = add_list empty lst - - let to_list = elements - end - end + module SetString = Set.Make(String) + let set_string_add_list st lst = + List.fold_left + (fun acc e -> SetString.add e acc) + st + lst - module SetString = SetExt.Make(String) + let set_string_of_list = + set_string_add_list + SetString.empty let compare_csl s1 s2 = String.compare (String.lowercase s1) (String.lowercase s2) - module HashStringCsl = Hashtbl.Make (struct @@ -330,14 +257,6 @@ module OASISUtils = struct Hashtbl.hash (String.lowercase s) end) - module SetStringCsl = - SetExt.Make - (struct - type t = string - let compare = compare_csl - end) - - let varname_of_string ?(hyphen='_') s = if String.length s = 0 then begin @@ -368,7 +287,6 @@ module OASISUtils = struct String.lowercase buf end - let varname_concat ?(hyphen='_') p s = let what = String.make 1 hyphen in let p = @@ -389,49 +307,42 @@ module OASISUtils = struct let is_varname str = str = varname_of_string str - let failwithf fmt = Printf.ksprintf failwith fmt - end module PropList = struct -(* # 22 "src/oasis/PropList.ml" *) - +(* # 21 "src/oasis/PropList.ml" *) open OASISGettext - type name = string - exception Not_set of name * string option exception No_printer of name exception Unknown_field of name * name - let () = Printexc.register_printer (function | Not_set (nm, Some rsn) -> - Some + Some (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) | Not_set (nm, None) -> - Some + Some (Printf.sprintf (f_ "Field '%s' is not set") nm) | No_printer nm -> Some (Printf.sprintf (f_ "No default printer for value %s") nm) | Unknown_field (nm, schm) -> - Some - (Printf.sprintf - (f_ "Field %s is not defined in schema %s") nm schm) + Some + (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm) | _ -> None) - module Data = struct + type t = (name, unit -> unit) Hashtbl.t @@ -441,13 +352,12 @@ module PropList = struct let clear t = Hashtbl.clear t - -(* # 78 "src/oasis/PropList.ml" *) +(* # 71 "src/oasis/PropList.ml" *) end - module Schema = struct + type ('ctxt, 'extra) value = { get: Data.t -> string; @@ -535,9 +445,9 @@ module PropList = struct t.name end - module Field = struct + type ('ctxt, 'value, 'extra) t = { set: Data.t -> ?context:'ctxt -> 'value -> unit; @@ -667,27 +577,28 @@ module PropList = struct let fgets data t = t.gets data - end + end module FieldRO = struct + let create ?schema ?name ?parse ?print ?default ?update ?help extra = let fld = Field.create ?schema ?name ?parse ?print ?default ?update ?help extra in fun data -> Field.fget data fld + end end module OASISMessage = struct -(* # 22 "src/oasis/OASISMessage.ml" *) +(* # 21 "src/oasis/OASISMessage.ml" *) open OASISGettext open OASISContext - let generic_message ~ctxt lvl fmt = let cond = if ctxt.quiet then @@ -706,39 +617,30 @@ module OASISMessage = struct end) fmt - let debug ~ctxt fmt = generic_message ~ctxt `Debug fmt - let info ~ctxt fmt = generic_message ~ctxt `Info fmt - let warning ~ctxt fmt = generic_message ~ctxt `Warning fmt - let error ~ctxt fmt = generic_message ~ctxt `Error fmt end module OASISVersion = struct -(* # 22 "src/oasis/OASISVersion.ml" *) - +(* # 21 "src/oasis/OASISVersion.ml" *) open OASISGettext - - type s = string - - type t = string - + type t = string type comparator = | VGreater of t @@ -748,24 +650,20 @@ module OASISVersion = struct | VLesserEqual of t | VOr of comparator * comparator | VAnd of comparator * comparator - - + (* Range of allowed characters *) let is_digit c = '0' <= c && c <= '9' - let is_alpha c = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') - let is_special = function | '.' | '+' | '-' | '~' -> true | _ -> false - let rec version_compare v1 v2 = if v1 <> "" || v2 <> "" then begin @@ -809,11 +707,11 @@ module OASISVersion = struct while !p < String.length v && is_digit v.[!p] do incr p done; - let substr = + let substr = String.sub v !p ((String.length v) - !p) - in - let res = - match String.sub v start_p (!p - start_p) with + in + let res = + match String.sub v start_p (!p - start_p) with | "" -> 0 | s -> int_of_string s in @@ -849,14 +747,8 @@ module OASISVersion = struct let version_of_string str = str - let string_of_version t = t - - let version_compare_string s1 s2 = - version_compare (version_of_string s1) (version_of_string s2) - - let chop t = try let pos = @@ -866,7 +758,6 @@ module OASISVersion = struct with Not_found -> t - let rec comparator_apply v op = match op with | VGreater cv -> @@ -884,7 +775,6 @@ module OASISVersion = struct | VAnd (op1, op2) -> (comparator_apply v op1) && (comparator_apply v op2) - let rec string_of_comparator = function | VGreater v -> "> "^(string_of_version v) @@ -897,7 +787,6 @@ module OASISVersion = struct | VAnd (c1, c2) -> (string_of_comparator c1)^" && "^(string_of_comparator c2) - let rec varname_of_comparator = let concat p v = OASISUtils.varname_concat @@ -916,24 +805,13 @@ module OASISVersion = struct | VAnd (c1, c2) -> (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) - - let rec comparator_ge v' = - let cmp v = version_compare v v' >= 0 in - function - | VEqual v - | VGreaterEqual v - | VGreater v -> cmp v - | VLesserEqual _ - | VLesser _ -> false - | VOr (c1, c2) -> comparator_ge v' c1 || comparator_ge v' c2 - | VAnd (c1, c2) -> comparator_ge v' c1 && comparator_ge v' c2 - + let version_0_3_or_after t = + comparator_apply t (VGreaterEqual (string_of_version "0.3")) end module OASISLicense = struct -(* # 22 "src/oasis/OASISLicense.ml" *) - +(* # 21 "src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall @@ -941,20 +819,15 @@ module OASISLicense = struct + type license = string - - type license = string - - - type license_exception = string - + type license_exception = string type license_version = | Version of OASISVersion.t | VersionOrLater of OASISVersion.t | NoVersion - - + type license_dep_5_unit = { @@ -962,38 +835,31 @@ module OASISLicense = struct excption: license_exception option; version: license_version; } - - + type license_dep_5 = | DEP5Unit of license_dep_5_unit | DEP5Or of license_dep_5 list | DEP5And of license_dep_5 list - + type t = | DEP5License of license_dep_5 | OtherLicense of string (* URL *) - - + end module OASISExpr = struct -(* # 22 "src/oasis/OASISExpr.ml" *) - - +(* # 21 "src/oasis/OASISExpr.ml" *) open OASISGettext + type test = string - type test = string - - - type flag = string - + type flag = string type t = | EBool of bool @@ -1002,11 +868,9 @@ module OASISExpr = struct | EOr of t * t | EFlag of flag | ETest of test * string + - - - type 'a choices = (t * 'a) list - + type 'a choices = (t * 'a) list let eval var_get t = let rec eval' = @@ -1038,7 +902,6 @@ module OASISExpr = struct in eval' t - let choose ?printer ?name var_get lst = let rec choose_aux = function @@ -1075,66 +938,44 @@ module OASISExpr = struct in choose_aux (List.rev lst) - -end - -module OASISText = struct -(* # 22 "src/oasis/OASISText.ml" *) - - - - type elt = - | Para of string - | Verbatim of string - | BlankLine - - - type t = elt list - end module OASISTypes = struct -(* # 22 "src/oasis/OASISTypes.ml" *) - - - +(* # 21 "src/oasis/OASISTypes.ml" *) - type name = string - type package_name = string - type url = string - type unix_dirname = string - type unix_filename = string - type host_dirname = string - type host_filename = string - type prog = string - type arg = string - type args = string list - type command_line = (prog * arg list) - type findlib_name = string - type findlib_full = string + type name = string + type package_name = string + type url = string + type unix_dirname = string + type unix_filename = string + type host_dirname = string + type host_filename = string + type prog = string + type arg = string + type args = string list + type command_line = (prog * arg list) + type findlib_name = string + type findlib_full = string type compiled_object = | Byte | Native | Best - - + type dependency = | FindlibPackage of findlib_full * OASISVersion.comparator option | InternalLibrary of name - - + type tool = | ExternalTool of name | InternalExecutable of name - - + type vcs = | Darcs @@ -1146,8 +987,7 @@ module OASISTypes = struct | Arch | Monotone | OtherVCS of url - - + type plugin_kind = [ `Configure @@ -1158,7 +998,6 @@ module OASISTypes = struct | `Extra ] - type plugin_data_purpose = [ `Configure | `Build @@ -1173,29 +1012,22 @@ module OASISTypes = struct | `Other of string ] - - type 'a plugin = 'a * name * OASISVersion.t option - + type 'a plugin = 'a * name * OASISVersion.t option type all_plugin = plugin_kind plugin - type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list +(* # 102 "src/oasis/OASISTypes.ml" *) -(* # 115 "src/oasis/OASISTypes.ml" *) - - - type 'a conditional = 'a OASISExpr.choices - + type 'a conditional = 'a OASISExpr.choices type custom = { pre_command: (command_line option) conditional; post_command: (command_line option) conditional; } - - + type common_section = { @@ -1203,8 +1035,7 @@ module OASISTypes = struct cs_data: PropList.Data.t; cs_plugin_data: plugin_data; } - - + type build_section = { @@ -1223,8 +1054,7 @@ module OASISTypes = struct bs_byteopt: args conditional; bs_nativeopt: args conditional; } - - + type library = { @@ -1234,29 +1064,19 @@ module OASISTypes = struct lib_findlib_parent: findlib_name option; lib_findlib_name: findlib_name option; 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; - } - + } type flag = { flag_description: string option; flag_default: bool conditional; - } - + } type source_repository = { @@ -1267,8 +1087,7 @@ module OASISTypes = struct src_repo_branch: string option; src_repo_tag: string option; src_repo_subdir: unix_filename option; - } - + } type test = { @@ -1278,8 +1097,7 @@ module OASISTypes = struct test_working_directory: unix_filename option; test_run: bool conditional; test_tools: tool list; - } - + } type doc_format = | HTML of unix_filename @@ -1289,8 +1107,7 @@ module OASISTypes = struct | Info of unix_filename | DVI | OtherDoc - - + type doc = { @@ -1305,459 +1122,75 @@ module OASISTypes = struct doc_format: doc_format; doc_data_files: (unix_filename * unix_filename option) list; doc_build_tools: tool list; - } - + } 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 - | Test of common_section * test - | Doc of common_section * doc - - - - type section_kind = - [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] - - - type package = - { - oasis_version: OASISVersion.t; - ocaml_version: OASISVersion.comparator option; - findlib_version: OASISVersion.comparator option; - alpha_features: string list; - beta_features: string list; - name: package_name; - version: OASISVersion.t; - license: OASISLicense.t; - license_file: unix_filename option; - copyrights: string list; - maintainers: string list; - authors: string list; - homepage: url option; - synopsis: string; - description: OASISText.t option; - categories: url list; - - conf_type: [`Configure] plugin; - conf_custom: custom; - - build_type: [`Build] plugin; - build_custom: custom; - - install_type: [`Install] plugin; - install_custom: custom; - uninstall_custom: custom; - - clean_custom: custom; - distclean_custom: custom; - - files_ab: unix_filename list; - sections: section list; - plugins: [`Extra] plugin list; - disable_oasis_section: unix_filename list; - schema_data: PropList.Data.t; - plugin_data: plugin_data; - } - - -end - -module OASISFeatures = struct -(* # 22 "src/oasis/OASISFeatures.ml" *) - - open OASISTypes - open OASISUtils - open OASISGettext - open OASISVersion - - module MapPlugin = - Map.Make - (struct - type t = plugin_kind * name - let compare = Pervasives.compare - end) - - module Data = - struct - type t = - { - oasis_version: OASISVersion.t; - plugin_versions: OASISVersion.t option MapPlugin.t; - alpha_features: string list; - beta_features: string list; - } - - let create oasis_version alpha_features beta_features = - { - oasis_version = oasis_version; - plugin_versions = MapPlugin.empty; - alpha_features = alpha_features; - beta_features = beta_features - } - - let of_package pkg = - create - pkg.OASISTypes.oasis_version - pkg.OASISTypes.alpha_features - pkg.OASISTypes.beta_features - - let add_plugin (plugin_kind, plugin_name, plugin_version) t = - {t with - plugin_versions = MapPlugin.add - (plugin_kind, plugin_name) - plugin_version - t.plugin_versions} - - let plugin_version plugin_kind plugin_name t = - MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions - - let to_string t = - Printf.sprintf - "oasis_version: %s; alpha_features: %s; beta_features: %s; \ - plugins_version: %s" - (OASISVersion.string_of_version t.oasis_version) - (String.concat ", " t.alpha_features) - (String.concat ", " t.beta_features) - (String.concat ", " - (MapPlugin.fold - (fun (_, plg) ver_opt acc -> - (plg^ - (match ver_opt with - | Some v -> - " "^(OASISVersion.string_of_version v) - | None -> "")) - :: acc) - t.plugin_versions [])) - end - - type origin = - | Field of string * string - | Section of string - | NoOrigin - - type stage = Alpha | Beta - - - let string_of_stage = - function - | Alpha -> "alpha" - | Beta -> "beta" - - - let field_of_stage = - function - | Alpha -> "AlphaFeatures" - | Beta -> "BetaFeatures" - - type publication = InDev of stage | SinceVersion of OASISVersion.t - - type t = - { - name: string; - plugin: all_plugin option; - publication: publication; - description: unit -> string; - } - - (* TODO: mutex protect this. *) - let all_features = Hashtbl.create 13 - - - let since_version ver_str = SinceVersion (version_of_string ver_str) - let alpha = InDev Alpha - let beta = InDev Beta - - - let to_string t = - Printf.sprintf - "feature: %s; plugin: %s; publication: %s" - t.name - (match t.plugin with - | None -> "" - | Some (_, nm, _) -> nm) - (match t.publication with - | InDev stage -> string_of_stage stage - | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) - - let data_check t data origin = - let no_message = "no message" in - - let check_feature features stage = - let has_feature = List.mem t.name features in - if not has_feature then - match origin with - | Field (fld, where) -> - Some - (Printf.sprintf - (f_ "Field %s in %s is only available when feature %s \ - is in field %s.") - fld where t.name (field_of_stage stage)) - | Section sct -> - Some - (Printf.sprintf - (f_ "Section %s is only available when features %s \ - is in field %s.") - sct t.name (field_of_stage stage)) - | NoOrigin -> - Some no_message - else - None - in - - let version_is_good ~min_version version fmt = - let version_is_good = - OASISVersion.comparator_apply - version (OASISVersion.VGreaterEqual min_version) - in - Printf.ksprintf - (fun str -> - if version_is_good then - None - else - Some str) - fmt - in - - match origin, t.plugin, t.publication with - | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha - | _, _, InDev Beta -> check_feature data.Data.beta_features Beta - | Field(fld, where), None, SinceVersion min_version -> - version_is_good ~min_version data.Data.oasis_version - (f_ "Field %s in %s is only valid since OASIS v%s, update \ - OASISFormat field from '%s' to '%s' after checking \ - OASIS changelog.") - fld where (string_of_version min_version) - (string_of_version data.Data.oasis_version) - (string_of_version min_version) - - | Field(fld, where), Some(plugin_knd, plugin_name, _), - SinceVersion min_version -> - begin - try - let plugin_version_current = - try - match Data.plugin_version plugin_knd plugin_name data with - | Some ver -> ver - | None -> - failwithf - (f_ "Field %s in %s is only valid for the OASIS \ - plugin %s since v%s, but no plugin version is \ - defined in the _oasis file, change '%s' to \ - '%s (%s)' in your _oasis file.") - fld where plugin_name (string_of_version min_version) - plugin_name - plugin_name (string_of_version min_version) - with Not_found -> - failwithf - (f_ "Field %s in %s is only valid when the OASIS plugin %s \ - is defined.") - fld where plugin_name - in - version_is_good ~min_version plugin_version_current - (f_ "Field %s in %s is only valid for the OASIS plugin %s \ - since v%s, update your plugin from '%s (%s)' to \ - '%s (%s)' after checking the plugin's changelog.") - fld where plugin_name (string_of_version min_version) - plugin_name (string_of_version plugin_version_current) - plugin_name (string_of_version min_version) - with Failure msg -> - Some msg - end - - | Section sct, None, SinceVersion min_version -> - version_is_good ~min_version data.Data.oasis_version - (f_ "Section %s is only valid for since OASIS v%s, update \ - OASISFormat field from '%s' to '%s' after checking OASIS \ - changelog.") - sct (string_of_version min_version) - (string_of_version data.Data.oasis_version) - (string_of_version min_version) - - | Section sct, Some(plugin_knd, plugin_name, _), - SinceVersion min_version -> - begin - try - let plugin_version_current = - try - match Data.plugin_version plugin_knd plugin_name data with - | Some ver -> ver - | None -> - failwithf - (f_ "Section %s is only valid for the OASIS \ - plugin %s since v%s, but no plugin version is \ - defined in the _oasis file, change '%s' to \ - '%s (%s)' in your _oasis file.") - sct plugin_name (string_of_version min_version) - plugin_name - plugin_name (string_of_version min_version) - with Not_found -> - failwithf - (f_ "Section %s is only valid when the OASIS plugin %s \ - is defined.") - sct plugin_name - in - version_is_good ~min_version plugin_version_current - (f_ "Section %s is only valid for the OASIS plugin %s \ - since v%s, update your plugin from '%s (%s)' to \ - '%s (%s)' after checking the plugin's changelog.") - sct plugin_name (string_of_version min_version) - plugin_name (string_of_version plugin_version_current) - plugin_name (string_of_version min_version) - with Failure msg -> - Some msg - end - - | NoOrigin, None, SinceVersion min_version -> - version_is_good ~min_version data.Data.oasis_version "%s" no_message - - | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> - begin - try - let plugin_version_current = - match Data.plugin_version plugin_knd plugin_name data with - | Some ver -> ver - | None -> raise Not_found - in - version_is_good ~min_version plugin_version_current - "%s" no_message - with Not_found -> - Some no_message - end - - - let data_assert t data origin = - match data_check t data origin with - | None -> () - | Some str -> failwith str - - - let data_test t data = - match data_check t data NoOrigin with - | None -> true - | Some str -> false - - - let package_test t pkg = - data_test t (Data.of_package pkg) - - - let create ?plugin name publication description = - let () = - if Hashtbl.mem all_features name then - failwithf "Feature '%s' is already declared." name - in - let t = - { - name = name; - plugin = plugin; - publication = publication; - description = description; - } - in - Hashtbl.add all_features name t; - t - - - let get_stage name = - try - (Hashtbl.find all_features name).publication - with Not_found -> - failwithf (f_ "Feature %s doesn't exist.") name - - - let list () = - Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] - - (* - * Real flags. - *) - - - let features = - create "features_fields" - (since_version "0.4") - (fun () -> - s_ "Enable to experiment not yet official features.") - - - let flag_docs = - create "flag_docs" - (since_version "0.3") - (fun () -> - s_ "Building docs require '-docs' flag at configure.") - - - let flag_tests = - create "flag_tests" - (since_version "0.3") - (fun () -> - s_ "Running tests require '-tests' flag at configure.") - - - let pack = - create "pack" - (since_version "0.3") - (fun () -> - s_ "Allow to create packed library.") - - - let section_object = - create "section_object" beta - (fun () -> - s_ "Implement an object section.") - - - let dynrun_for_release = - create "dynrun_for_release" alpha - (fun () -> - s_ "Make '-setup-update dynamic' suitable for releasing project.") - + | Library of common_section * build_section * library + | Executable of common_section * build_section * executable + | Flag of common_section * flag + | SrcRepo of common_section * source_repository + | Test of common_section * test + | Doc of common_section * doc + - let compiled_setup_ml = - create "compiled_setup_ml" alpha - (fun () -> - s_ "It compiles the setup.ml and speed-up actions done with it.") + type section_kind = + [ `Library | `Executable | `Flag | `SrcRepo | `Test | `Doc ] - let disable_oasis_section = - create "disable_oasis_section" alpha - (fun () -> - s_ "Allows the OASIS section comments and digest to be omitted in \ - generated files.") + type package = + { + oasis_version: OASISVersion.t; + ocaml_version: OASISVersion.comparator option; + findlib_version: OASISVersion.comparator option; + name: package_name; + version: OASISVersion.t; + license: OASISLicense.t; + license_file: unix_filename option; + copyrights: string list; + maintainers: string list; + authors: string list; + homepage: url option; + synopsis: string; + description: string option; + categories: url list; + + conf_type: [`Configure] plugin; + conf_custom: custom; + + build_type: [`Build] plugin; + build_custom: custom; + + install_type: [`Install] plugin; + install_custom: custom; + uninstall_custom: custom; + + clean_custom: custom; + distclean_custom: custom; + + files_ab: unix_filename list; + sections: section list; + plugins: [`Extra] plugin list; + schema_data: PropList.Data.t; + plugin_data: plugin_data; + } - let no_automatic_syntax = - create "no_automatic_syntax" alpha - (fun () -> - s_ "Disable the automatic inclusion of -syntax camlp4o for packages \ - that matches the internal heuristic (if a dependency ends with \ - a .syntax or is a well known syntax).") end module OASISUnixPath = struct -(* # 22 "src/oasis/OASISUnixPath.ml" *) - +(* # 21 "src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string - type host_filename = string type host_dirname = string - let current_dir_name = "." - let parent_dir_name = ".." - let is_current_dir fn = fn = current_dir_name || fn = "" - let concat f1 f2 = if is_current_dir f1 then f2 @@ -1767,7 +1200,6 @@ module OASISUnixPath = struct in f1'^"/"^f2 - let make = function | hd :: tl -> @@ -1778,14 +1210,12 @@ module OASISUnixPath = struct | [] -> invalid_arg "OASISUnixPath.make" - let dirname f = try String.sub f 0 (String.rindex f '/') with Not_found -> current_dir_name - let basename f = try let pos_start = @@ -1795,7 +1225,6 @@ module OASISUnixPath = struct with Not_found -> f - let chop_extension f = try let last_dot = @@ -1818,31 +1247,26 @@ module OASISUnixPath = struct with Not_found -> f - let capitalize_file f = let dir = dirname f in let base = basename f in concat dir (String.capitalize base) - let uncapitalize_file f = let dir = dirname f in let base = basename f in concat dir (String.uncapitalize base) - end module OASISHostPath = struct -(* # 22 "src/oasis/OASISHostPath.ml" *) +(* # 21 "src/oasis/OASISHostPath.ml" *) open Filename - module Unix = OASISUnixPath - let make = function | [] -> @@ -1850,7 +1274,6 @@ module OASISHostPath = struct | hd :: tl -> List.fold_left Filename.concat hd tl - let of_unix ufn = if Sys.os_type = "Unix" then ufn @@ -1870,18 +1293,14 @@ module OASISHostPath = struct end module OASISSection = struct -(* # 22 "src/oasis/OASISSection.ml" *) - +(* # 21 "src/oasis/OASISSection.ml" *) open OASISTypes - - let section_kind_common = + let section_kind_common = function - | Library (cs, _, _) -> + | Library (cs, _, _) -> `Library, cs - | Object (cs, _, _) -> - `Object, cs | Executable (cs, _, _) -> `Executable, cs | Flag (cs, _) -> @@ -1893,38 +1312,32 @@ module OASISSection = struct | Doc (cs, _) -> `Doc, cs - let section_common sct = snd (section_kind_common sct) - 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) | Test (_, tst) -> Test (cs, tst) | Doc (_, doc) -> Doc (cs, doc) - (** Key used to identify section *) - let section_id sct = - let k, cs = + let section_id sct = + let k, cs = section_kind_common sct in k, cs.cs_name - let string_of_section sct = let k, nm = section_id sct in (match k with - | `Library -> "library" - | `Object -> "object" + | `Library -> "library" | `Executable -> "executable" | `Flag -> "flag" | `SrcRepo -> "src repository" @@ -1932,22 +1345,20 @@ module OASISSection = struct | `Doc -> "doc") ^" "^nm - let section_find id scts = List.find (fun sct -> id = section_id sct) scts - module CSection = struct type t = section let id = section_id - let compare t1 t2 = + let compare t1 t2 = compare (id t1) (id t2) - + let equal t1 t2 = (id t1) = (id t2) @@ -1955,33 +1366,28 @@ module OASISSection = struct Hashtbl.hash (id t) end - module MapSection = Map.Make(CSection) module SetSection = Set.Make(CSection) - end module OASISBuildSection = struct -(* # 22 "src/oasis/OASISBuildSection.ml" *) - +(* # 21 "src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct -(* # 22 "src/oasis/OASISExecutable.ml" *) - +(* # 21 "src/oasis/OASISExecutable.ml" *) open OASISTypes - - let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = - let dir = + let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = + let dir = OASISUnixPath.concat bs.bs_path (OASISUnixPath.dirname exec.exec_main_is) in - let is_native_exec = + let is_native_exec = match bs.bs_compiled_object with | Native -> true | Best -> is_native () @@ -1992,28 +1398,40 @@ module OASISExecutable = struct dir (cs.cs_name^(suffix_program ())), - if not is_native_exec && - not exec.exec_custom && + if not is_native_exec && + not exec.exec_custom && bs.bs_c_sources <> [] then Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) else None - end module OASISLibrary = struct -(* # 22 "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) @@ -2051,11 +1469,10 @@ module OASISLibrary = struct (`No_sources possible_base_fn) possible_base_fn - 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 _ -> @@ -2068,7 +1485,6 @@ module OASISLibrary = struct [] (lib.lib_modules @ lib.lib_internal_modules) - let generated_unix_files ~ctxt ~is_native @@ -2078,49 +1494,50 @@ module OASISLibrary = struct ~source_file_exists (cs, bs, lib) = - let find_modules lst ext = + let find_modules lst ext = let find_module modul = - match find_module source_file_exists bs modul with - | `Sources (base_fn, [fn]) when ext <> "cmi" - && Filename.check_suffix fn ".mli" -> - None (* No implementation files for pure interface. *) + match find_module source_file_exists (cs, bs, lib) modul with | `Sources (base_fn, _) -> - Some [base_fn] + [base_fn] | `No_sources lst -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; - Some lst + lst in - List.fold_left - (fun acc nm -> - match find_module nm with - | None -> acc - | Some base_fns -> - List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) - [] + List.map + (fun nm -> + List.map + (fun base_fn -> base_fn ^"."^ext) + (find_module nm)) lst in + (* The headers that should be compiled along *) + let headers = + if lib.lib_pack then + [] + else + find_modules + lib.lib_modules + "cmi" + in + (* The .cmx that be compiled along *) let cmxs = let should_be_built = + (not lib.lib_pack) && (* Do not install .cmx packed submodules *) match bs.bs_compiled_object with | Native -> true | Best -> is_native | Byte -> false in if should_be_built then - if lib.lib_pack then - find_modules - [cs.cs_name] - "cmx" - else - find_modules - (lib.lib_modules @ lib.lib_internal_modules) - "cmx" + find_modules + (lib.lib_modules @ lib.lib_internal_modules) + "cmx" else [] in @@ -2129,32 +1546,12 @@ module OASISLibrary = struct [] in - (* The headers and annot/cmt files that should be compiled along *) - let headers = - let sufx = - if lib.lib_pack - then [".cmti"; ".cmt"; ".annot"] - else [".cmi"; ".cmti"; ".cmt"; ".annot"] - in - List.map - begin - List.fold_left - begin fun accu s -> - let dot = String.rindex s '.' in - let base = String.sub s 0 dot in - List.map ((^) base) sufx @ accu - end - [] - end - (find_modules lib.lib_modules "cmi") - in - (* Compute what libraries should be built *) let acc_nopath = (* Add the packed header file if required *) let add_pack_header acc = if lib.lib_pack then - [cs.cs_name^".cmi"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: acc + [cs.cs_name^".cmi"] :: acc else acc in @@ -2162,7 +1559,7 @@ module OASISLibrary = struct add_pack_header ([cs.cs_name^".cma"] :: acc) in let native acc = - let acc = + let acc = add_pack_header (if has_native_dynlink then [cs.cs_name^".cmxs"] :: acc @@ -2201,113 +1598,11 @@ module OASISLibrary = struct acc_nopath) (headers @ cmxs) - -end - -module OASISObject = struct -(* # 22 "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 -(* # 22 "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 - let findlib_mapping pkg = (* Map from library name to either full findlib name or parts + parent. *) let fndlb_parts_of_lib_name = @@ -2346,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 @@ -2430,7 +1708,7 @@ module OASISFindlib = struct let lib_name = cs.cs_name in findlib_name_of_library_name lib_name in - let rec add_children nm_lst (children: tree MapString.t) = + let rec add_children nm_lst (children : tree MapString.t) = match nm_lst with | (hd :: tl) -> begin @@ -2500,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 @@ -2514,13 +1790,13 @@ module OASISFindlib = struct in let library_name_of_findlib_name = - lazy begin - (* Revert findlib_name_of_library_name. *) - MapString.fold - (fun k v mp -> MapString.add v k mp) - fndlb_name_of_lib_name - MapString.empty - end + Lazy.lazy_from_fun + (fun () -> + (* Revert findlib_name_of_library_name. *) + MapString.fold + (fun k v mp -> MapString.add v k mp) + fndlb_name_of_lib_name + MapString.empty) in let library_name_of_findlib_name fndlb_nm = try @@ -2533,13 +1809,11 @@ module OASISFindlib = struct findlib_name_of_library_name, library_name_of_findlib_name - let findlib_of_group = function | Container (fndlb_nm, _) | Package (fndlb_nm, _, _, _, _) -> fndlb_nm - let root_of_group grp = let rec root_lib_aux = (* We do a DFS in the group. *) @@ -2564,48 +1838,40 @@ module OASISFindlib = struct (f_ "Unable to determine root library of findlib library '%s'") (findlib_of_group grp) - end module OASISFlag = struct -(* # 22 "src/oasis/OASISFlag.ml" *) - +(* # 21 "src/oasis/OASISFlag.ml" *) end module OASISPackage = struct -(* # 22 "src/oasis/OASISPackage.ml" *) - +(* # 21 "src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct -(* # 22 "src/oasis/OASISSourceRepository.ml" *) - +(* # 21 "src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct -(* # 22 "src/oasis/OASISTest.ml" *) - +(* # 21 "src/oasis/OASISTest.ml" *) end module OASISDocument = struct -(* # 22 "src/oasis/OASISDocument.ml" *) - +(* # 21 "src/oasis/OASISDocument.ml" *) end module OASISExec = struct -(* # 22 "src/oasis/OASISExec.ml" *) - +(* # 21 "src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils open OASISMessage - (* TODO: I don't like this quote, it is there because $(rm) foo expands to * 'rm -f' foo... *) @@ -2636,7 +1902,6 @@ module OASISExec = struct | Some f, i -> f i - let run_read_output ~ctxt ?f_exit_code cmd args = let fn = Filename.temp_file "oasis-" ".txt" @@ -2668,7 +1933,6 @@ module OASISExec = struct (try Sys.remove fn with _ -> ()); raise e - let run_read_one_line ~ctxt ?f_exit_code cmd args = match run_read_output ~ctxt ?f_exit_code cmd args with | [fst] -> @@ -2680,12 +1944,10 @@ module OASISExec = struct end module OASISFileUtil = struct -(* # 22 "src/oasis/OASISFileUtil.ml" *) - +(* # 21 "src/oasis/OASISFileUtil.ml" *) open OASISGettext - let file_exists_case fn = let dirname = Filename.dirname fn in let basename = Filename.basename fn in @@ -2699,7 +1961,6 @@ module OASISFileUtil = struct else false - let find_file ?(case_sensitive=true) paths exts = (* Cardinal product of two list *) @@ -2708,7 +1969,7 @@ module OASISFileUtil = struct (List.map (fun a -> List.map - (fun b -> a, b) + (fun b -> a,b) lst2) lst1) in @@ -2718,7 +1979,7 @@ module OASISFileUtil = struct | p1 :: p2 :: tl -> let acc = (List.map - (fun (a, b) -> Filename.concat a b) + (fun (a,b) -> Filename.concat a b) (p1 * p2)) in combined_paths (acc :: tl) @@ -2730,21 +1991,19 @@ module OASISFileUtil = struct let alternatives = List.map - (fun (p, e) -> + (fun (p,e) -> if String.length e > 0 && e.[0] <> '.' then p ^ "." ^ e else p ^ e) ((combined_paths paths) * exts) in - List.find (fun file -> + List.find (if case_sensitive then - file_exists_case file + file_exists_case else - Sys.file_exists file) - && not (Sys.is_directory file) - ) alternatives - + Sys.file_exists) + alternatives let which ~ctxt prg = let path_sep = @@ -2764,7 +2023,6 @@ module OASISFileUtil = struct in find_file ~case_sensitive:false [path_lst; [prg]] exec_ext - (**/**) let rec fix_dir dn = (* Windows hack because Sys.file_exists "src\\" = false when @@ -2778,11 +2036,9 @@ module OASISFileUtil = struct else dn - let q = Filename.quote (**/**) - let cp ~ctxt ?(recurse=false) src tgt = if recurse then match Sys.os_type with @@ -2799,7 +2055,6 @@ module OASISFileUtil = struct | _ -> "cp") [q src; q tgt] - let mkdir ~ctxt tgt = OASISExec.run ~ctxt (match Sys.os_type with @@ -2807,7 +2062,6 @@ module OASISFileUtil = struct | _ -> "mkdir") [q tgt] - let rec mkdir_parent ~ctxt f tgt = let tgt = fix_dir tgt @@ -2830,20 +2084,15 @@ module OASISFileUtil = struct end end - let rmdir ~ctxt tgt = - if Sys.readdir tgt = [||] then begin - match Sys.os_type with - | "Win32" -> - OASISExec.run ~ctxt "rd" [q tgt] - | _ -> - OASISExec.run ~ctxt "rm" ["-r"; q tgt] - end else begin - OASISMessage.error ~ctxt - (f_ "Cannot remove directory '%s': not empty.") - tgt - end - + if Sys.readdir tgt = [||] then + begin + match Sys.os_type with + | "Win32" -> + OASISExec.run ~ctxt "rd" [q tgt] + | _ -> + OASISExec.run ~ctxt "rm" ["-r"; q tgt] + end let glob ~ctxt fn = let basename = @@ -2890,23 +2139,19 @@ module OASISFileUtil = struct end -# 2893 "setup.ml" +# 2142 "setup.ml" module BaseEnvLight = struct -(* # 22 "src/base/BaseEnvLight.ml" *) - +(* # 21 "src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) - type t = string MapString.t - let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" - let load ?(allow_empty=false) ?(filename=default_filename) () = if Sys.file_exists filename then begin @@ -2964,29 +2209,26 @@ module BaseEnvLight = struct filename) end - - let rec var_expand str env = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) env - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff - - let var_get name env = - var_expand (MapString.find name env) env - + let rec var_expand str = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + in + var_expand (MapString.find name env) let var_choose lst env = OASISExpr.choose @@ -2995,24 +2237,20 @@ module BaseEnvLight = struct end -# 2998 "setup.ml" +# 2240 "setup.ml" module BaseContext = struct -(* # 22 "src/base/BaseContext.ml" *) +(* # 21 "src/base/BaseContext.ml" *) - (* TODO: get rid of this module. *) open OASISContext - - let args () = fst (fspecs ()) - + let args = args let default = default end module BaseMessage = struct -(* # 22 "src/base/BaseMessage.ml" *) - +(* # 21 "src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall @@ -3020,38 +2258,31 @@ module BaseMessage = struct open OASISMessage open BaseContext - let debug fmt = debug ~ctxt:!default fmt - let info fmt = info ~ctxt:!default fmt - let warning fmt = warning ~ctxt:!default fmt - let error fmt = error ~ctxt:!default fmt end module BaseEnv = struct -(* # 22 "src/base/BaseEnv.ml" *) +(* # 21 "src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils open PropList - module MapString = BaseEnvLight.MapString - type origin_t = | ODefault | OGetEnv | OFileLoad | OCommandLine - type cli_handle_t = | CLINone | CLIAuto @@ -3059,7 +2290,6 @@ module BaseEnv = struct | CLIEnable | CLIUser of (Arg.key * Arg.spec * Arg.doc) list - type definition_t = { hide: bool; @@ -3069,26 +2299,21 @@ module BaseEnv = struct group: string option; } - let schema = Schema.create "environment" - (* Environment data *) let env = Data.create () - (* Environment data from file *) let env_from_file = ref MapString.empty - (* Lexer for var *) let var_lxr = Genlex.make_lexer [] - let rec var_expand str = let buff = Buffer.create ((String.length str) * 2) @@ -3139,7 +2364,6 @@ module BaseEnv = struct str; Buffer.contents buff - and var_get name = let vl = try @@ -3154,7 +2378,6 @@ module BaseEnv = struct in var_expand vl - let var_choose ?printer ?name lst = OASISExpr.choose ?printer @@ -3162,7 +2385,6 @@ module BaseEnv = struct var_get lst - let var_protect vl = let buff = Buffer.create (String.length vl) @@ -3174,7 +2396,6 @@ module BaseEnv = struct vl; Buffer.contents buff - let var_define ?(hide=false) ?(dump=true) @@ -3260,7 +2481,6 @@ module BaseEnv = struct fun () -> var_expand (var_get_low (var_get_lst env)) - let var_redefine ?hide ?dump @@ -3289,9 +2509,8 @@ module BaseEnv = struct dflt end - - let var_ignore (e: unit -> string) = () - + let var_ignore (e : unit -> string) = + () let print_hidden = var_define @@ -3302,7 +2521,6 @@ module BaseEnv = struct "print_hidden" (fun () -> "false") - let var_all () = List.rev (Schema.fold @@ -3314,28 +2532,24 @@ module BaseEnv = struct [] schema) - let default_filename = BaseEnvLight.default_filename - let load ?allow_empty ?filename () = env_from_file := BaseEnvLight.load ?allow_empty ?filename () - let unload () = env_from_file := MapString.empty; Data.clear env - let dump ?(filename=default_filename) () = let chn = open_out_bin filename in - let output nm value = + let output nm value = Printf.fprintf chn "%s=%S\n" nm value in - let mp_todo = + let mp_todo = (* Dump data from schema *) Schema.fold (fun mp_todo nm def _ -> @@ -3362,7 +2576,6 @@ module BaseEnv = struct (* End of the dump *) close_out chn - let print () = let printable_vars = Schema.fold @@ -3401,12 +2614,11 @@ module BaseEnv = struct Printf.printf "\nConfiguration: \n"; List.iter - (fun (name, value) -> + (fun (name,value) -> Printf.printf "%s: %s %s\n" name (dot_pad name) value) (List.rev printable_vars); Printf.printf "\n%!" - let args () = let arg_concat = OASISUtils.varname_concat ~hyphen:'-' @@ -3517,13 +2729,11 @@ module BaseEnv = struct end module BaseArgExt = struct -(* # 22 "src/base/BaseArgExt.ml" *) - +(* # 21 "src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext - let parse argv args = (* Simulate command line for Arg *) let current = @@ -3547,15 +2757,13 @@ module BaseArgExt = struct end module BaseCheck = struct -(* # 22 "src/base/BaseCheck.ml" *) - +(* # 21 "src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage open OASISUtils open OASISGettext - let prog_best prg prg_lst = var_redefine prg @@ -3578,19 +2786,15 @@ module BaseCheck = struct | Some prg -> prg | None -> raise Not_found) - let prog prg = prog_best prg [prg] - let prog_opt prg = prog_best prg [prg^".opt"; prg] - let ocamlfind = prog "ocamlfind" - let version var_prefix cmp @@ -3632,13 +2836,11 @@ module BaseCheck = struct version_str) () - let package_version pkg = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%v"; pkg] - let package ?version_comparator pkg () = let var = OASISUtils.varname_concat @@ -3681,21 +2883,18 @@ module BaseCheck = struct end module BaseOCamlcConfig = struct -(* # 22 "src/base/BaseOCamlcConfig.ml" *) +(* # 21 "src/base/BaseOCamlcConfig.ml" *) open BaseEnv open OASISUtils open OASISGettext - module SMap = Map.Make(String) - let ocamlc = BaseCheck.prog_opt "ocamlc" - let ocamlc_config_map = (* Map name to value for ocamlc -config output (name ^": "^value) @@ -3741,7 +2940,7 @@ module BaseOCamlcConfig = struct mp in - let cache = + let cache = lazy (var_protect (Marshal.to_string @@ -3760,7 +2959,6 @@ module BaseOCamlcConfig = struct (* TODO: update if ocamlc change !!! *) Lazy.force cache) - let var_define nm = (* Extract data from ocamlc -config *) let avlbl_config_get () = @@ -3769,15 +2967,15 @@ module BaseOCamlcConfig = struct 0 in let chop_version_suffix s = - try + try String.sub s 0 (String.index s '+') - with _ -> + with _ -> s in let nm_config, value_config = match nm with - | "ocaml_version" -> + | "ocaml_version" -> "version", chop_version_suffix | _ -> nm, (fun x -> x) in @@ -3801,7 +2999,7 @@ module BaseOCamlcConfig = struct end module BaseStandardVar = struct -(* # 22 "src/base/BaseStandardVar.ml" *) +(* # 21 "src/base/BaseStandardVar.ml" *) open OASISGettext @@ -3810,7 +3008,6 @@ module BaseStandardVar = struct open BaseCheck open BaseEnv - let ocamlfind = BaseCheck.ocamlfind let ocamlc = BaseOCamlcConfig.ocamlc let ocamlopt = prog_opt "ocamlopt" @@ -3821,16 +3018,13 @@ module BaseStandardVar = struct let rpkg = ref None - let pkg_get () = match !rpkg with | Some pkg -> pkg | None -> failwith (s_ "OASIS Package is not set") - let var_cond = ref [] - let var_define_cond ~since_version f dflt = let holder = ref (fun () -> dflt) in let since_version = @@ -3842,17 +3036,14 @@ module BaseStandardVar = struct holder := f ()) :: !var_cond; fun () -> !holder () - (**/**) - let pkg_name = var_define ~short_desc:(fun () -> s_ "Package name") "pkg_name" (fun () -> (pkg_get ()).name) - let pkg_version = var_define ~short_desc:(fun () -> s_ "Package version") @@ -3860,20 +3051,16 @@ module BaseStandardVar = struct (fun () -> (OASISVersion.string_of_version (pkg_get ()).version)) - let c = BaseOCamlcConfig.var_define - let os_type = c "os_type" let system = c "system" let architecture = c "architecture" let ccomp_type = c "ccomp_type" let ocaml_version = c "ocaml_version" - (* TODO: Check standard variable presence at runtime *) - let standard_library_default = c "standard_library_default" let standard_library = c "standard_library" let standard_runtime = c "standard_runtime" @@ -3887,27 +3074,24 @@ module BaseStandardVar = struct let default_executable_name = c "default_executable_name" let systhread_supported = c "systhread_supported" - - let flexlink = + let flexlink = BaseCheck.prog "flexlink" - let flexdll_version = var_define ~short_desc:(fun () -> "FlexDLL version (Win32)") "flexdll_version" (fun () -> - let lst = + let lst = OASISExec.run_read_output ~ctxt:!BaseContext.default (flexlink ()) ["-help"] in - match lst with + match lst with | line :: _ -> Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) | [] -> raise Not_found) - (**/**) let p name hlp dflt = var_define @@ -3917,7 +3101,6 @@ module BaseStandardVar = struct name dflt - let (/) a b = if os_type () = Sys.os_type then Filename.concat a b @@ -3928,7 +3111,6 @@ module BaseStandardVar = struct (os_type ()) (**/**) - let prefix = p "prefix" (fun () -> s_ "Install architecture-independent files dir") @@ -3942,115 +3124,96 @@ module BaseStandardVar = struct | _ -> "/usr/local") - let exec_prefix = p "exec_prefix" (fun () -> s_ "Install architecture-dependent files in dir") (fun () -> "$prefix") - let bindir = p "bindir" (fun () -> s_ "User executables") (fun () -> "$exec_prefix"/"bin") - let sbindir = p "sbindir" (fun () -> s_ "System admin executables") (fun () -> "$exec_prefix"/"sbin") - let libexecdir = p "libexecdir" (fun () -> s_ "Program executables") (fun () -> "$exec_prefix"/"libexec") - let sysconfdir = p "sysconfdir" (fun () -> s_ "Read-only single-machine data") (fun () -> "$prefix"/"etc") - let sharedstatedir = p "sharedstatedir" (fun () -> s_ "Modifiable architecture-independent data") (fun () -> "$prefix"/"com") - let localstatedir = p "localstatedir" (fun () -> s_ "Modifiable single-machine data") (fun () -> "$prefix"/"var") - let libdir = p "libdir" (fun () -> s_ "Object code libraries") (fun () -> "$exec_prefix"/"lib") - let datarootdir = p "datarootdir" (fun () -> s_ "Read-only arch-independent data root") (fun () -> "$prefix"/"share") - let datadir = p "datadir" (fun () -> s_ "Read-only architecture-independent data") (fun () -> "$datarootdir") - let infodir = p "infodir" (fun () -> s_ "Info documentation") (fun () -> "$datarootdir"/"info") - let localedir = p "localedir" (fun () -> s_ "Locale-dependent data") (fun () -> "$datarootdir"/"locale") - let mandir = p "mandir" (fun () -> s_ "Man documentation") (fun () -> "$datarootdir"/"man") - let docdir = p "docdir" (fun () -> s_ "Documentation root") (fun () -> "$datarootdir"/"doc"/"$pkg_name") - let htmldir = p "htmldir" (fun () -> s_ "HTML documentation") (fun () -> "$docdir") - let dvidir = p "dvidir" (fun () -> s_ "DVI documentation") (fun () -> "$docdir") - let pdfdir = p "pdfdir" (fun () -> s_ "PDF documentation") (fun () -> "$docdir") - let psdir = p "psdir" (fun () -> s_ "PS documentation") (fun () -> "$docdir") - let destdir = p "destdir" (fun () -> s_ "Prepend a path when installing package") @@ -4060,39 +3223,35 @@ module BaseStandardVar = struct ("destdir", Some (s_ "undefined by construct")))) - let findlib_version = var_define "findlib_version" (fun () -> BaseCheck.package_version "findlib") - let is_native = var_define "is_native" (fun () -> try - let _s: string = + let _s : string = ocamlopt () in "true" with PropList.Not_set _ -> - let _s: string = + let _s : string = ocamlc () in "false") - let ext_program = var_define "suffix_program" (fun () -> match os_type () with - | "Win32" | "Cygwin" -> ".exe" + | "Win32" -> ".exe" | _ -> "") - let rm = var_define ~short_desc:(fun () -> s_ "Remove a file.") @@ -4102,7 +3261,6 @@ module BaseStandardVar = struct | "Win32" -> "del" | _ -> "rm -f") - let rmdir = var_define ~short_desc:(fun () -> s_ "Remove a directory.") @@ -4112,7 +3270,6 @@ module BaseStandardVar = struct | "Win32" -> "rd" | _ -> "rm -rf") - let debug = var_define ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") @@ -4120,7 +3277,6 @@ module BaseStandardVar = struct "debug" (fun () -> "true") - let profile = var_define ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") @@ -4128,7 +3284,6 @@ module BaseStandardVar = struct "profile" (fun () -> "false") - let tests = var_define_cond ~since_version:"0.3" (fun () -> @@ -4140,7 +3295,6 @@ module BaseStandardVar = struct (fun () -> "false")) "true" - let docs = var_define_cond ~since_version:"0.3" (fun () -> @@ -4151,7 +3305,6 @@ module BaseStandardVar = struct (fun () -> "true")) "true" - let native_dynlink = var_define ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") @@ -4159,7 +3312,7 @@ module BaseStandardVar = struct "native_dynlink" (fun () -> let res = - let ocaml_lt_312 () = + let ocaml_lt_312 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (ocaml_version ())) (OASISVersion.VLesser @@ -4171,7 +3324,7 @@ module BaseStandardVar = struct (OASISVersion.VLesser (OASISVersion.version_of_string "0.30")) in - let has_native_dynlink = + let has_native_dynlink = let ocamlfind = ocamlfind () in try let fn = @@ -4189,10 +3342,10 @@ module BaseStandardVar = struct false else if ocaml_lt_312 () then false - else if (os_type () = "Win32" || os_type () = "Cygwin") + else if (os_type () = "Win32" || os_type () = "Cygwin") && flexdll_lt_030 () then begin - BaseMessage.warning + BaseMessage.warning (f_ ".cmxs generation disabled because FlexDLL needs to be \ at least 0.30. Please upgrade FlexDLL from %s to 0.30.") (flexdll_version ()); @@ -4203,7 +3356,6 @@ module BaseStandardVar = struct in string_of_bool res) - let init pkg = rpkg := Some pkg; List.iter (fun f -> f pkg.oasis_version) !var_cond @@ -4211,14 +3363,12 @@ module BaseStandardVar = struct end module BaseFileAB = struct -(* # 22 "src/base/BaseFileAB.ml" *) - +(* # 21 "src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext open BaseMessage - let to_filename fn = let fn = OASISHostPath.of_unix fn @@ -4229,7 +3379,6 @@ module BaseFileAB = struct fn; Filename.chop_extension fn - let replace fn_lst = let buff = Buffer.create 13 @@ -4262,18 +3411,15 @@ module BaseFileAB = struct end module BaseLog = struct -(* # 22 "src/base/BaseLog.ml" *) - +(* # 21 "src/base/BaseLog.ml" *) open OASISUtils - let default_filename = Filename.concat (Filename.dirname BaseEnv.default_filename) "setup.log" - module SetTupleString = Set.Make (struct @@ -4284,7 +3430,6 @@ module BaseLog = struct | n -> n end) - let load () = if Sys.file_exists default_filename then begin @@ -4334,7 +3479,6 @@ module BaseLog = struct [] end - let register event data = let chn_out = open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename @@ -4342,7 +3486,6 @@ module BaseLog = struct Printf.fprintf chn_out "%S %S\n" event data; close_out chn_out - let unregister event data = if Sys.file_exists default_filename then begin @@ -4368,7 +3511,6 @@ module BaseLog = struct Sys.remove default_filename end - let filter events = let st_events = List.fold_left @@ -4381,7 +3523,6 @@ module BaseLog = struct (fun (e, _) -> SetString.mem e st_events) (load ()) - let exists event data = List.exists (fun v -> (event, data) = v) @@ -4389,38 +3530,31 @@ module BaseLog = struct end module BaseBuilt = struct -(* # 22 "src/base/BaseBuilt.ml" *) - +(* # 21 "src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext open BaseStandardVar open BaseMessage - type t = | BExec (* Executable *) | BExecLib (* Library coming with executable *) | BLib (* Library *) - | BObj (* Library *) | BDoc (* Document *) - let to_log_event_file t nm = "built_"^ (match t with | BExec -> "exec" | BExecLib -> "exec_lib" | BLib -> "lib" - | BObj -> "obj" | BDoc -> "doc")^ "_"^nm - let to_log_event_done t nm = "is_"^(to_log_event_file t nm) - let register t nm lst = BaseLog.register (to_log_event_done t nm) @@ -4451,7 +3585,6 @@ module BaseBuilt = struct (String.concat (s_ ", ") alt)) lst - let unregister t nm = List.iter (fun (e, d) -> @@ -4460,7 +3593,6 @@ module BaseBuilt = struct [to_log_event_file t nm; to_log_event_done t nm]) - let fold t nm f acc = List.fold_left (fun acc (_, fn) -> @@ -4480,8 +3612,6 @@ module BaseBuilt = struct (f_ "executable %s") | BLib -> (f_ "library %s") - | BObj -> - (f_ "object %s") | BDoc -> (f_ "documentation %s")) nm); @@ -4491,7 +3621,6 @@ module BaseBuilt = struct (BaseLog.filter [to_log_event_file t nm]) - let is_built t nm = List.fold_left (fun is_built (_, d) -> @@ -4503,7 +3632,6 @@ module BaseBuilt = struct (BaseLog.filter [to_log_event_done t nm]) - let of_executable ffn (cs, bs, exec) = let unix_exec_is, unix_dll_opt = OASISExecutable.unix_exec_is @@ -4527,7 +3655,6 @@ module BaseBuilt = struct unix_exec_is, unix_dll_opt - let of_library ffn (cs, bs, lib) = let unix_lst = OASISLibrary.generated_unix_files @@ -4547,35 +3674,16 @@ 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 -(* # 22 "src/base/BaseCustom.ml" *) - +(* # 21 "src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext - let run cmd args extra_args = OASISExec.run ~ctxt:!BaseContext.default ~quote:false (var_expand cmd) @@ -4583,7 +3691,6 @@ module BaseCustom = struct var_expand (args @ (Array.to_list extra_args))) - let hook ?(failsafe=false) cstm f e = let optional_command lst = let printer = @@ -4620,7 +3727,7 @@ module BaseCustom = struct end module BaseDynVar = struct -(* # 22 "src/base/BaseDynVar.ml" *) +(* # 21 "src/base/BaseDynVar.ml" *) open OASISTypes @@ -4628,7 +3735,6 @@ module BaseDynVar = struct open BaseEnv open BaseBuilt - let init pkg = (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) (* TODO: provide compile option for library libary_byte_args_VARNAME... *) @@ -4662,14 +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 -(* # 22 "src/base/BaseTest.ml" *) - +(* # 21 "src/base/BaseTest.ml" *) open BaseEnv open BaseMessage @@ -4677,7 +3782,6 @@ module BaseTest = struct open OASISExpr open OASISGettext - let test lst pkg extra_args = let one_test (failure, n) (test_plugin, cs, test) = @@ -4728,7 +3832,7 @@ module BaseTest = struct (failure, n) end in - let failed, n = + let (failed, n) = List.fold_left one_test (0.0, 0) @@ -4751,7 +3855,7 @@ module BaseTest = struct info "%s" msg; (* Possible explanation why the tests where not run. *) - if OASISFeatures.package_test OASISFeatures.flag_tests pkg && + if OASISVersion.version_0_3_or_after pkg.oasis_version && not (bool_of_string (BaseStandardVar.tests ())) && lst <> [] then BaseMessage.warning @@ -4760,15 +3864,13 @@ module BaseTest = struct end module BaseDoc = struct -(* # 22 "src/base/BaseDoc.ml" *) - +(* # 21 "src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext - let doc lst pkg extra_args = let one_doc (doc_plugin, cs, doc) = @@ -4788,7 +3890,7 @@ module BaseDoc = struct in List.iter one_doc lst; - if OASISFeatures.package_test OASISFeatures.flag_docs pkg && + if OASISVersion.version_0_3_or_after pkg.oasis_version && not (bool_of_string (BaseStandardVar.docs ())) && lst <> [] then BaseMessage.warning @@ -4797,7 +3899,7 @@ module BaseDoc = struct end module BaseSetup = struct -(* # 22 "src/base/BaseSetup.ml" *) +(* # 21 "src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage @@ -4806,15 +3908,12 @@ module BaseSetup = struct open OASISGettext open OASISUtils - type std_args_fun = package -> string array -> unit - type ('a, 'b) section_args_fun = name * (package -> (common_section * 'a) -> string array -> 'b) - type t = { configure: std_args_fun; @@ -4838,7 +3937,6 @@ module BaseSetup = struct setup_update: bool; } - (* Associate a plugin function with data from package *) let join_plugin_sections filter_map lst = List.rev @@ -4852,7 +3950,6 @@ module BaseSetup = struct [] lst) - (* Search for plugin data associated with a section name *) let lookup_plugin_section plugin action nm lst = try @@ -4864,12 +3961,11 @@ module BaseSetup = struct nm action - let configure t args = (* Run configure *) BaseCustom.hook t.package.conf_custom - (fun () -> + (fun () -> (* Reload if preconf has changed it *) begin try @@ -4896,14 +3992,12 @@ module BaseSetup = struct (* Replace data in file *) BaseFileAB.replace t.package.files_ab - let build t args = BaseCustom.hook t.package.build_custom (t.build t.package) args - let doc t args = BaseDoc.doc (join_plugin_sections @@ -4923,7 +4017,6 @@ module BaseSetup = struct t.package args - let test t args = BaseTest.test (join_plugin_sections @@ -4943,16 +4036,12 @@ module BaseSetup = struct t.package args - let all t args = let rno_doc = ref false in let rno_test = ref false - in - let arg_rest = - ref [] in Arg.parse_argv ~current:(ref 0) @@ -4967,16 +4056,12 @@ module BaseSetup = struct "-no-test", Arg.Set rno_test, s_ "Don't run test target"; - - "--", - Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), - s_ "All arguments for configure."; ] (failwithf (f_ "Don't know what to do with '%s'")) ""; info "Running configure step"; - configure t (Array.of_list (List.rev !arg_rest)); + configure t [||]; info "Running build step"; build t [||]; @@ -5004,26 +4089,22 @@ module BaseSetup = struct info "Skipping test step" end - let install t args = BaseCustom.hook t.package.install_custom (t.install t.package) args - let uninstall t args = BaseCustom.hook t.package.uninstall_custom (t.uninstall t.package) args - let reinstall t args = uninstall t args; install t args - let clean, distclean = let failsafe f a = try @@ -5065,7 +4146,6 @@ module BaseSetup = struct (f t.package (cs, doc)) args | Library _ - | Object _ | Executable _ | Flag _ | SrcRepo _ -> @@ -5121,11 +4201,9 @@ module BaseSetup = struct clean, distclean - let version t _ = print_endline t.oasis_version - let update_setup_ml, no_update_setup_ml_cli = let b = ref true in b, @@ -5133,15 +4211,11 @@ module BaseSetup = struct Arg.Clear b, s_ " Don't try to update setup.ml, even if _oasis has changed.") - - let default_oasis_fn = "_oasis" - - let update_setup_ml t = let oasis_fn = match t.oasis_fn with | Some fn -> fn - | None -> default_oasis_fn + | None -> "_oasis" in let oasis_exec = match t.oasis_exec with @@ -5239,8 +4313,7 @@ module BaseSetup = struct try match t.oasis_digest with | Some dgst -> - if Sys.file_exists oasis_fn && - dgst <> Digest.file default_oasis_fn then + if Sys.file_exists oasis_fn && dgst <> Digest.file "_oasis" then begin do_update (); true @@ -5260,7 +4333,6 @@ module BaseSetup = struct else false - let setup t = let catch_exn = ref true @@ -5402,34 +4474,41 @@ module BaseSetup = struct error "%s" (Printexc.to_string e); exit 1 - end -# 5409 "setup.ml" +# 4480 "setup.ml" module InternalConfigurePlugin = struct -(* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) - +(* # 21 "src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall *) - open BaseEnv open OASISTypes open OASISUtils open OASISGettext open BaseMessage - (** Configure build using provided series of check to be done * and then output corresponding file. *) let configure pkg argv = - let var_ignore_eval var = let _s: string = var () in () in - let errors = ref SetString.empty in - let buff = Buffer.create 13 in + let var_ignore_eval var = + let _s : string = + var () + in + () + in + + let errors = + ref SetString.empty + in + + let buff = + Buffer.create 13 + in let add_errors fmt = Printf.kbprintf @@ -5577,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" || @@ -5653,58 +4718,43 @@ module InternalConfigurePlugin = struct (SetString.cardinal !errors) end - end module InternalInstallPlugin = struct -(* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *) - +(* # 21 "src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall *) - open BaseEnv open BaseStandardVar open BaseMessage open OASISTypes - open OASISFindlib + open OASISLibrary open OASISGettext open OASISUtils - let exec_hook = ref (fun (cs, bs, exec) -> cs, bs, exec) - 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) - let install_file_ev = "install-file" - let install_dir_ev = "install-dir" - let install_findlib_ev = "install-findlib" - let win32_max_command_line_length = 8000 - let split_install_command ocamlfind findlib_name meta files = if Sys.os_type = "Win32" then (* Arguments for the first command: *) @@ -5744,21 +4794,20 @@ module InternalInstallPlugin = struct | (firsts, others) -> let cmd = args @ firsts in (* Use -add for remaining commands: *) - let () = + let () = let findlib_ge_132 = OASISVersion.comparator_apply - (OASISVersion.version_of_string + (OASISVersion.version_of_string (BaseStandardVar.findlib_version ())) - (OASISVersion.VGreaterEqual + (OASISVersion.VGreaterEqual (OASISVersion.version_of_string "1.3.2")) in if not findlib_ge_132 then failwithf - (f_ "Installing the library %s require to use the \ - flag '-add' of ocamlfind because the command \ - line is too long. This flag is only available \ - for findlib 1.3.2. Please upgrade findlib from \ - %s to 1.3.2") + (f_ "Installing the library %s require to use the flag \ + '-add' of ocamlfind because the command line is too \ + long. This flag is only available for findlib 1.3.2. \ + Please upgrade findlib from %s to 1.3.2") findlib_name (BaseStandardVar.findlib_version ()) in let cmds = split other_args others in @@ -5769,7 +4818,6 @@ module InternalInstallPlugin = struct else ["install" :: findlib_name :: meta :: files] - let install pkg argv = let in_destdir = @@ -5842,17 +4890,6 @@ module InternalInstallPlugin = struct lst in - let make_fnames modul sufx = - List.fold_right - begin fun sufx accu -> - (String.capitalize modul ^ sufx) :: - (String.uncapitalize modul ^ sufx) :: - accu - end - sufx - [] - in - (** Install all libraries *) let install_libs pkg = @@ -5873,29 +4910,27 @@ module InternalInstallPlugin = struct OASISHostPath.of_unix bs.bs_path in List.fold_left - begin fun acc modul -> - begin - try - [List.find - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".mli"; ".ml"]))] - with Not_found -> - warning - (f_ "Cannot find source header for module %s \ - in library %s") - modul cs.cs_name; - [] - end - @ - List.filter - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".annot";".cmti";".cmt"])) - @ acc - end + (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 library %s") + modul cs.cs_name; + acc + end) acc lib.lib_modules in @@ -5926,77 +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 - begin fun acc modul -> - begin - try - [List.find - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".mli"; ".ml"]))] - with Not_found -> - warning - (f_ "Cannot find source header for module %s \ - in object %s") - modul cs.cs_name; - [] - end - @ - List.filter - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".annot";".cmti";".cmt"])) - @ 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 *) @@ -6007,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 @@ -6044,7 +5006,7 @@ module InternalInstallPlugin = struct begin let meta = (* Search META file *) - let _, bs, _ = + let (_, bs, _) = root_lib in let res = @@ -6057,7 +5019,7 @@ module InternalInstallPlugin = struct findlib_name; res in - let files = + let files = (* Make filename shorter to avoid hitting command max line length * too early, esp. on Windows. *) @@ -6066,24 +5028,24 @@ module InternalInstallPlugin = struct let nlen = String.length n in if plen <= nlen && String.sub n 0 plen = p then begin - let fn_sep = + let fn_sep = if Sys.os_type = "Win32" then '\\' else '/' in let cutpoint = plen + - (if plen < nlen && n.[plen] = fn_sep then + (if plen < nlen && n.[plen] = fn_sep then 1 - else + else 0) in String.sub n cutpoint (nlen - cutpoint) end - else + else n in - List.map (remove_prefix (Sys.getcwd ())) files + List.map (remove_prefix (Sys.getcwd ())) files in info (f_ "Installing findlib library '%s'") @@ -6117,7 +5079,7 @@ module InternalInstallPlugin = struct let install_execs pkg = let install_exec data_exec = - let cs, bs, exec = + let (cs, bs, exec) = !exec_hook data_exec in if var_choose bs.bs_install && @@ -6164,7 +5126,7 @@ module InternalInstallPlugin = struct let install_docs pkg = let install_doc data = - let cs, doc = + let (cs, doc) = !doc_hook data in if var_choose doc.doc_install && @@ -6200,7 +5162,6 @@ module InternalInstallPlugin = struct install_execs pkg; install_docs pkg - (* Uninstall already installed data *) let uninstall _ argv = List.iter @@ -6264,34 +5225,24 @@ module InternalInstallPlugin = struct (BaseLog.filter [install_file_ev; install_dir_ev; - install_findlib_ev])) - + install_findlib_ev;])) end -# 6273 "setup.ml" +# 5233 "setup.ml" module OCamlbuildCommon = struct -(* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) - +(* # 21 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) - open OASISGettext open BaseEnv open BaseStandardVar - open OASISTypes - - - - - type extra_args = string list - - - let ocamlbuild_clean_ev = "ocamlbuild-clean" + let ocamlbuild_clean_ev = + "ocamlbuild-clean" let ocamlbuildflags = var_define @@ -6299,7 +5250,6 @@ module OCamlbuildCommon = struct "ocamlbuildflags" (fun () -> "") - (** Fix special arguments depending on environment *) let fix_args args extra_argv = List.flatten @@ -6328,11 +5278,6 @@ module OCamlbuildCommon = struct else []; - if bool_of_string (tests ()) then - ["-tag"; "tests"] - else - []; - if bool_of_string (profile ()) then ["-tag"; "profile"] else @@ -6343,7 +5288,6 @@ module OCamlbuildCommon = struct Array.to_list extra_argv; ] - (** Run 'ocamlbuild -clean' if not already done *) let run_clean extra_argv = let extra_cli = @@ -6363,7 +5307,6 @@ module OCamlbuildCommon = struct ()) end - (** Run ocamlbuild, unregister all clean events *) let run_ocamlbuild args extra_argv = (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html @@ -6375,7 +5318,6 @@ module OCamlbuildCommon = struct (fun (e, d) -> BaseLog.unregister e d) (BaseLog.filter [ocamlbuild_clean_ev]) - (** Determine real build directory *) let build_dir extra_argv = let rec search_args dir = @@ -6389,36 +5331,28 @@ module OCamlbuildCommon = struct in search_args "_build" (fix_args [] extra_argv) - end module OCamlbuildPlugin = struct -(* # 22 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) - +(* # 21 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall *) - open OASISTypes open OASISGettext open OASISUtils - open OASISString open BaseEnv open OCamlbuildCommon open BaseStandardVar open BaseMessage - - - - let cond_targets_hook = ref (fun lst -> lst) + let build pkg argv = - let build extra_args pkg argv = (* Return the filename in build directory *) let in_build_dir fn = Filename.concat @@ -6443,36 +5377,16 @@ module OCamlbuildPlugin = struct (cs, bs, lib) in - let tgts = - List.flatten - (List.filter - (fun l -> l <> []) - (List.map - (List.filter - (fun fn -> - ends_with ~what:".cma" fn - || ends_with ~what:".cmxs" fn - || ends_with ~what:".cmxa" fn - || ends_with ~what:(ext_lib ()) fn - || ends_with ~what:(ext_dll ()) fn)) - unix_files)) - in - - match tgts with - | _ :: _ -> - (evs, tgts) :: acc - | [] -> - failwithf - (f_ "No possible ocamlbuild targets for library %s") - 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) + 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 = @@ -6482,8 +5396,11 @@ module OCamlbuildPlugin = struct (List.map (List.filter (fun fn -> - ends_with ".cmo" fn - || ends_with ".cmx" fn)) + ends_with ".cma" fn + || ends_with ".cmxs" fn + || ends_with ".cmxa" fn + || ends_with (ext_lib ()) fn + || ends_with (ext_dll ()) fn)) unix_files)) in @@ -6492,7 +5409,7 @@ module OCamlbuildPlugin = struct (evs, tgts) :: acc | [] -> failwithf - (f_ "No possible ocamlbuild targets for object %s") + (f_ "No possible ocamlbuild targets for library %s") cs.cs_name end @@ -6511,13 +5428,12 @@ module OCamlbuildPlugin = struct (OASISUnixPath.chop_extension exec.exec_main_is))^ext in - let evs = + let evs = (* Fix evs, we want to use the unix_tgt, without copying *) List.map (function | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> - BaseBuilt.BExec, nm, - [[in_build_dir_of_unix unix_tgt]] + BaseBuilt.BExec, nm, [[in_build_dir_of_unix unix_tgt]] | ev -> ev) evs @@ -6539,7 +5455,7 @@ module OCamlbuildPlugin = struct acc end - | Library _ | Object _ | Executable _ | Test _ + | Library _ | Executable _ | Test _ | SrcRepo _ | Flag _ | Doc _ -> acc) [] @@ -6553,22 +5469,26 @@ module OCamlbuildPlugin = struct (fun fns -> if not (List.exists OASISFileUtil.file_exists_case fns) then failwithf - (fn_ - "Expected built file %s doesn't exist." - "None of expected built files %s exists." - (List.length fns)) - (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) + (f_ "No one of expected built files %s exists") + (String.concat (s_ ", ") (List.map (Printf.sprintf "'%s'") fns))) lst; (BaseBuilt.register bt bnm lst) in - (* Run the hook *) - let cond_targets = !cond_targets_hook cond_targets in + let cond_targets = + (* Run the hook *) + !cond_targets_hook cond_targets + in - (* Run a list of target... *) - run_ocamlbuild (List.flatten (List.map snd cond_targets) @ extra_args) argv; - (* ... and register events *) - List.iter check_and_register (List.flatten (List.map fst cond_targets)) + (* Run a list of target... *) + run_ocamlbuild + (List.flatten + (List.map snd cond_targets)) + argv; + (* ... and register events *) + List.iter + check_and_register + (List.flatten (List.map fst cond_targets)) let clean pkg extra_args = @@ -6584,18 +5504,15 @@ module OCamlbuildPlugin = struct ()) pkg.sections - end module OCamlbuildDocPlugin = struct -(* # 22 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) - +(* # 21 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall *) - open OASISTypes open OASISGettext open OASISMessage @@ -6604,19 +5521,11 @@ module OCamlbuildDocPlugin = struct - - type run_t = - { - extra_args: string list; - run_path: unix_filename; - } - - - let doc_build run pkg (cs, doc) argv = + let doc_build path pkg (cs, doc) argv = let index_html = OASISUnixPath.make [ - run.run_path; + path; cs.cs_name^".docdir"; "index.html"; ] @@ -6625,11 +5534,11 @@ module OCamlbuildDocPlugin = struct OASISHostPath.make [ build_dir argv; - OASISHostPath.of_unix run.run_path; + OASISHostPath.of_unix path; cs.cs_name^".docdir"; ] in - run_ocamlbuild (index_html :: run.extra_args) argv; + run_ocamlbuild [index_html] argv; List.iter (fun glb -> BaseBuilt.register @@ -6639,52 +5548,43 @@ module OCamlbuildDocPlugin = struct (Filename.concat tgt_dir glb)]) ["*.html"; "*.css"] - - let doc_clean run pkg (cs, doc) argv = + let doc_clean t pkg (cs, doc) argv = run_clean argv; BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name - end -# 6651 "setup.ml" +# 5558 "setup.ml" module CustomPlugin = struct -(* # 22 "src/plugins/custom/CustomPlugin.ml" *) - +(* # 21 "src/plugins/custom/CustomPlugin.ml" *) (** Generate custom configure/build/doc/test/install system @author *) - open BaseEnv open OASISGettext open OASISTypes - - type t = { cmd_main: command_line conditional; cmd_clean: (command_line option) conditional; cmd_distclean: (command_line option) conditional; - } - - - let run = BaseCustom.run + } + let run = BaseCustom.run let main t _ extra_args = let cmd, args = - var_choose - ~name:(s_ "main command") + var_choose + ~name:(s_ "main command") t.cmd_main in - run cmd args extra_args - + run cmd args extra_args let clean t pkg extra_args = match var_choose t.cmd_clean with @@ -6693,7 +5593,6 @@ module CustomPlugin = struct | _ -> () - let distclean t pkg extra_args = match var_choose t.cmd_distclean with | Some (cmd, args) -> @@ -6701,21 +5600,20 @@ module CustomPlugin = struct | _ -> () - module Build = - struct + struct let main t pkg extra_args = main t pkg extra_args; List.iter (fun sct -> let evs = - match sct with + match sct with | Library (cs, bs, lib) when var_choose bs.bs_build -> begin - let evs, _ = - BaseBuilt.of_library + let evs, _ = + BaseBuilt.of_library OASISHostPath.of_unix - (cs, bs, lib) + (cs, bs, lib) in evs end @@ -6756,7 +5654,6 @@ module CustomPlugin = struct distclean t pkg extra_args end - module Test = struct let main t pkg (cs, test) extra_args = @@ -6764,7 +5661,7 @@ module CustomPlugin = struct main t pkg extra_args; 0.0 with Failure s -> - BaseMessage.warning + BaseMessage.warning (f_ "Test '%s' fails: %s") cs.cs_name s; @@ -6774,10 +5671,9 @@ module CustomPlugin = struct clean t pkg extra_args let distclean t pkg (cs, test) extra_args = - distclean t pkg extra_args + distclean t pkg extra_args end - module Doc = struct let main t pkg (cs, _) extra_args = @@ -6792,17 +5688,16 @@ module CustomPlugin = struct distclean t pkg extra_args end - end -# 6799 "setup.ml" +# 5694 "setup.ml" open OASISTypes;; let setup_t = { BaseSetup.configure = InternalConfigurePlugin.configure; - build = OCamlbuildPlugin.build []; + build = OCamlbuildPlugin.build; test = [ ("test_networkd", @@ -6811,8 +5706,8 @@ let setup_t = CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$network_test", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) + cmd_distclean = [(OASISExpr.EBool true, None)]; + }) ]; doc = []; install = InternalInstallPlugin.install; @@ -6826,8 +5721,8 @@ let setup_t = CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$network_test", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) + cmd_distclean = [(OASISExpr.EBool true, None)]; + }) ]; clean_doc = []; distclean = []; @@ -6839,8 +5734,8 @@ let setup_t = CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$network_test", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) + cmd_distclean = [(OASISExpr.EBool true, None)]; + }) ]; distclean_doc = []; package = @@ -6848,8 +5743,6 @@ let setup_t = oasis_version = "0.3"; ocaml_version = None; findlib_version = None; - alpha_features = []; - beta_features = []; name = "xcp-networkd"; version = "0.10.0"; license = @@ -6858,8 +5751,8 @@ let setup_t = { OASISLicense.license = "LGPL"; excption = Some "OCaml linking"; - version = OASISLicense.Version "2.1" - }); + version = OASISLicense.Version "2.1"; + }); license_file = None; copyrights = []; maintainers = []; @@ -6868,39 +5761,39 @@ let setup_t = synopsis = "XCP Network Daemon"; description = None; categories = []; - conf_type = (`Configure, "internal", Some "0.4"); + conf_type = (`Configure, "internal", Some "0.3"); conf_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - build_type = (`Build, "ocamlbuild", Some "0.4"); + post_command = [(OASISExpr.EBool true, None)]; + }; + build_type = (`Build, "ocamlbuild", Some "0.3"); build_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - install_type = (`Install, "internal", Some "0.4"); + post_command = [(OASISExpr.EBool true, None)]; + }; + install_type = (`Install, "internal", Some "0.3"); install_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; + post_command = [(OASISExpr.EBool true, None)]; + }; uninstall_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; + post_command = [(OASISExpr.EBool true, None)]; + }; clean_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; + post_command = [(OASISExpr.EBool true, None)]; + }; distclean_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; + post_command = [(OASISExpr.EBool true, None)]; + }; files_ab = []; sections = [ @@ -6908,8 +5801,8 @@ let setup_t = ({ cs_name = "profiling"; cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, + cs_plugin_data = []; + }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, false)]; @@ -6924,22 +5817,22 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, { lib_modules = ["Coverage"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; - lib_findlib_containers = [] - }); + lib_findlib_containers = []; + }); Library ({ cs_name = "networklibs"; cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, + cs_plugin_data = []; + }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; @@ -6957,7 +5850,7 @@ let setup_t = FindlibPackage ("systemd", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = ["link_stubs.c"; "netdev.h"]; + bs_c_sources = []; bs_data_files = []; bs_ccopt = [ @@ -6968,8 +5861,8 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, { lib_modules = ["Network_config"; "Network_utils"; "Jsonrpc_client"]; @@ -6977,14 +5870,14 @@ let setup_t = lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = Some "network-libs"; - lib_findlib_containers = [] - }); + lib_findlib_containers = []; + }); Executable ({ cs_name = "xcp_networkd"; cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, + cs_plugin_data = []; + }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, false)]; @@ -7014,15 +5907,15 @@ let setup_t = 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 = "networkd.ml"}); + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = true; exec_main_is = "networkd.ml"; }); Executable ({ cs_name = "networkd_db"; cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, + cs_plugin_data = []; + }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, false)]; @@ -7044,15 +5937,15 @@ let setup_t = 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 = "networkd_db.ml"}); + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = true; exec_main_is = "networkd_db.ml"; }); Executable ({ cs_name = "network_test"; cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, + cs_plugin_data = []; + }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, false)]; @@ -7074,24 +5967,24 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "network_test.ml"}); + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "network_test.ml"; }); Test ({ cs_name = "test_networkd"; cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, + cs_plugin_data = []; + }, { - test_type = (`Test, "custom", Some "0.4"); + test_type = (`Test, "custom", Some "0.3"); test_command = [(OASISExpr.EBool true, ("$network_test", []))]; test_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; + post_command = [(OASISExpr.EBool true, None)]; + }; test_working_directory = Some "."; test_run = [ @@ -7102,14 +5995,14 @@ let setup_t = OASISExpr.EFlag "tests"), true) ]; - test_tools = [ExternalTool "ocamlbuild"] - }); + test_tools = [ExternalTool "ocamlbuild"]; + }); Executable ({ cs_name = "cli"; cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, + cs_plugin_data = []; + }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; @@ -7132,15 +6025,15 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "network_cli.ml"}); + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "network_cli.ml"; }); Executable ({ cs_name = "jsonrpc_dummy"; cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, + cs_plugin_data = []; + }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, false)]; @@ -7155,25 +6048,24 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "jsonrpc_dummy.ml"}) + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "jsonrpc_dummy.ml"; }) ]; plugins = [(`Extra, "META", Some "0.2")]; - disable_oasis_section = []; schema_data = PropList.Data.create (); - plugin_data = [] - }; + plugin_data = []; + }; oasis_fn = Some "_oasis"; - oasis_version = "0.4.5"; - oasis_digest = Some "N\031\177\159p\148\031\214\203#{\193\028\015_\242"; + oasis_version = "0.3.0"; + oasis_digest = Some "y\007\213\140M(?\198\232KQps\t\171\199"; oasis_exec = None; oasis_setup_args = []; - setup_update = false - };; + setup_update = false; + };; let setup () = BaseSetup.setup setup_t;; -# 7178 "setup.ml" +# 6070 "setup.ml" (* OASIS_STOP *) let () = setup ();; From fd8725979ae818106b74f720bf4626bd1bb87dd2 Mon Sep 17 00:00:00 2001 From: Thomas Sanders Date: Fri, 12 May 2017 12:12:28 +0100 Subject: [PATCH 138/260] Add myself to CREDITS file Signed-off-by: Thomas Sanders --- CREDITS | 1 + 1 file changed, 1 insertion(+) diff --git a/CREDITS b/CREDITS index e100c4e4d..56f955d6d 100644 --- a/CREDITS +++ b/CREDITS @@ -19,6 +19,7 @@ Rob Hoes Stephen Rice Stephen Turner Thomas Gazagnaire +Thomas Sanders Tim Deegan Tom Wilkie Vincent Hanquez From 65ff314c0245269f4cc08a3eae018a79b7b3009d Mon Sep 17 00:00:00 2001 From: Frederico Mazzone Date: Thu, 18 May 2017 17:48:11 +0100 Subject: [PATCH 139/260] CP-22405: Log message for config file not existing Removes spurious backtrace occurring on first boot because config file `/var/lib/xcp/networkd.db` does not exist yet. Signed-off-by: Frederico Mazzone --- lib/network_config.ml | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/lib/network_config.ml b/lib/network_config.ml index 13de5b24d..3161318c8 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -90,8 +90,11 @@ let read_config () = try let config_json = Unixext.string_of_file config_file_path in config_json |> Jsonrpc.of_string |> config_t_of_rpc - with e -> - error "Error while trying to read networkd configuration: %s\n%s" - (Printexc.to_string e) (Printexc.get_backtrace ()); - raise Read_error - + with + | Unix.Unix_error (Unix.ENOENT, _, file) -> + info "Cannot read networkd configuration file %s because it does not exist." file; + raise Read_error + | e -> + info "Error while trying to read networkd configuration: %s\n%s" + (Printexc.to_string e) (Printexc.get_backtrace ()); + raise Read_error From 5a22c398d6a0928afee7fe29835d4195b5e7d050 Mon Sep 17 00:00:00 2001 From: Sharad Yadav Date: Thu, 8 Dec 2016 05:06:08 +0000 Subject: [PATCH 140/260] CP-14028: Update networkd_db program to output vlan config. networkd_db must provide interfaces, vlan tag and parent bridge details when asked for bridge_config for a vlan bridge. Signed-off-by: Sharad Yadav --- networkd_db/networkd_db.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/networkd_db/networkd_db.ml b/networkd_db/networkd_db.ml index 9fa176e57..ad2a19394 100644 --- a/networkd_db/networkd_db.ml +++ b/networkd_db/networkd_db.ml @@ -43,7 +43,11 @@ let _ = if List.mem_assoc !bridge config.bridge_config then begin let bridge_config = List.assoc !bridge config.bridge_config in let ifaces = List.flatten (List.map (fun (_, port) -> port.interfaces) bridge_config.ports) in - Printf.printf "interfaces=%s\n" (String.concat "," ifaces) + Printf.printf "interfaces=%s\n" (String.concat "," ifaces); + begin match bridge_config.vlan with + | None -> () + | Some (parent, id) -> Printf.printf "vlan=%d\nparent=%s\n" id parent + end end else begin rc := 1; Printf.fprintf stderr "Could not find bridge %s\n" !bridge; From 3b34a86ab2a326d98ca4626169cb3a95d5a71d9b Mon Sep 17 00:00:00 2001 From: sharad yadav Date: Wed, 22 Mar 2017 07:04:47 +0000 Subject: [PATCH 141/260] CA-242016: Add function `bridge_naming_convention`. This function will provide the bridge name based on device name. It is a copy of xapi `bridge_naming_convention` function. Signed-off-by: sharad yadav --- lib/network_config.ml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/lib/network_config.ml b/lib/network_config.ml index 3161318c8..ca7a0265d 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -26,6 +26,11 @@ exception Write_error let config_file_path = "/var/lib/xcp/networkd.db" +let bridge_naming_convention (device: string) = + if String.startswith "eth" device + then ("xenbr" ^ (String.sub device 3 (String.length device - 3))) + else ("br" ^ device) + let read_management_conf () = try let management_conf = Unixext.string_of_file ("/etc/firstboot.d/data/management.conf") in From 0ab9f2eeb85aca1db32297662e7283180e69bc8f Mon Sep 17 00:00:00 2001 From: Sharad Yadav Date: Thu, 2 Mar 2017 06:56:40 +0000 Subject: [PATCH 142/260] CA-242016: Fix read_management_conf for management vlan config. `xe-reset-networking` for management vlan config will write a temporary vlan bridge into inventory. If management conf has VLAN tag then xcp-networkd must create the management bridge with vlan config. Signed-off-by: Sharad Yadav --- lib/network_config.ml | 30 +++++++++++++++++++++++------- 1 file changed, 23 insertions(+), 7 deletions(-) diff --git a/lib/network_config.ml b/lib/network_config.ml index ca7a0265d..ebc0067c6 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -38,6 +38,7 @@ let read_management_conf () = let args = List.map (fun s -> match (String.split '=' s) with k :: [v] -> k, String.strip ((=) '\'') v | _ -> "", "") args in debug "Firstboot file management.conf has: %s" (String.concat "; " (List.map (fun (k, v) -> k ^ "=" ^ v) args)); let device = List.assoc "LABEL" args in + let vlan = if List.mem_assoc "VLAN" args then Some (List.assoc "VLAN" args) else None in Inventory.reread_inventory (); let bridge_name = Inventory.lookup Inventory._management_interface in debug "Management bridge in inventory file: %s" bridge_name; @@ -69,13 +70,28 @@ let read_management_conf () = in let phy_interface = {default_interface with persistent_i = true} in let bridge_interface = {default_interface with ipv4_conf; ipv4_gateway; persistent_i = true} in - let bridge = {default_bridge with - bridge_mac = Some mac; - ports = [device, {default_port with interfaces = [device]}]; - persistent_b = true - } in - {interface_config = [device, phy_interface; bridge_name, bridge_interface]; - bridge_config = [bridge_name, bridge]; + let interface_config, bridge_config = + let primary_bridge_conf = {default_bridge with + bridge_mac = Some mac; + ports = [device, {default_port with interfaces = [device]}]; + persistent_b = true + } in + match vlan with + | None -> + [device, phy_interface; bridge_name, bridge_interface], + [bridge_name, primary_bridge_conf] + | Some vlan -> + let parent = bridge_naming_convention device in + let secondary_bridge_conf = {default_bridge with + vlan = Some (parent, int_of_string vlan); + bridge_mac = (Some mac); + persistent_b = true + } in + let parent_bridge_interface = {default_interface with persistent_i = true} in + [device, phy_interface; parent, parent_bridge_interface; bridge_name, bridge_interface], + [parent, primary_bridge_conf; bridge_name, secondary_bridge_conf] + in + {interface_config = interface_config; bridge_config = bridge_config; gateway_interface = Some bridge_name; dns_interface = Some bridge_name} with e -> error "Error while trying to read firstboot data: %s\n%s" From 6c98d5f4fc9102d675b3d871b417f01645200d25 Mon Sep 17 00:00:00 2001 From: sharad yadav Date: Thu, 23 Mar 2017 06:38:40 +0000 Subject: [PATCH 143/260] CA-242016: Destroy existing vlan bridge Add a function `destroy_existing_vlan_bridge` to destroy the existing vlan bridge if new vlan bridge is getting created on matching parent and VLAN TAG. Signed-off-by: sharad yadav --- networkd/network_server.ml | 44 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 243baa7d0..0033ac808 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -490,12 +490,56 @@ module Bridge = struct | Bridge -> Sysfs.get_all_bridges () ) () + let destroy_existing_vlan_bridge name (parent, vlan) = + begin match !backend_kind with + | Openvswitch -> + let bridges = + let raw = Ovs.vsctl ["--bare"; "-f"; "table"; "--"; "--columns=name"; "find"; "port"; "fake_bridge=true"; "tag=" ^ (string_of_int vlan)] in + if raw <> "" then String.split '\n' (String.rtrim raw) else [] + in + let existing_bridges = + List.filter ( fun bridge -> + match Ovs.bridge_to_vlan bridge with + | Some (p, v) -> p = parent && v = vlan + | None -> false + ) bridges in + List.iter (fun bridge -> + if bridge <> name then begin + debug "Destroying existing bridge %s" bridge; + remove_config bridge; + ignore (Ovs.destroy_bridge bridge) + end + ) existing_bridges + | Bridge -> + let ifaces = Sysfs.bridge_to_interfaces parent in + let existing_bridges = + match List.filter (fun (_, tag, iface) -> tag = vlan && List.mem iface ifaces) (Proc.get_vlans ()) with + | [] -> [] + | (vlan_iface, _, _) :: _ -> + List.filter (fun bridge -> + List.mem vlan_iface (Sysfs.bridge_to_interfaces bridge) + ) (Sysfs.get_all_bridges ()) + in + List.iter (fun bridge -> + if bridge <> name then begin + debug "Destroying existing bridge %s" bridge; + Interface.bring_down () "Destroying existing bridge" ~name:bridge; + remove_config bridge; + List.iter (fun dev -> + Brctl.destroy_port bridge dev; + ) (Sysfs.bridge_to_interfaces bridge); + ignore (Brctl.destroy_bridge bridge) + end + ) existing_bridges + end + let create _ dbg ?vlan ?mac ?(other_config=[]) ~name () = Debug.with_thread_associated dbg (fun () -> debug "Creating bridge %s%s" name (match vlan with | None -> "" | Some (parent, vlan) -> Printf.sprintf " (VLAN %d on bridge %s)" vlan parent ); + Stdext.Opt.iter (destroy_existing_vlan_bridge name) vlan; update_config name {(get_config name) with vlan; bridge_mac=mac; other_config}; begin match !backend_kind with | Openvswitch -> From 9eb90235fefc158b7b7eca6fd901fd525a0ab7a5 Mon Sep 17 00:00:00 2001 From: Sharad Yadav Date: Thu, 4 May 2017 06:55:37 +0100 Subject: [PATCH 144/260] CA-237543: Fix vlan bridge ipv4 conf on destroying parent bridge. Issue: On destroying parent bridge of vlan during bond.create: 1) Doesn't set ipv4 conf for vlan bridge to None. 2) Vlan bridge gets destroyed automatically without stopping dhclient. It triggers, non starting of dhclient while recreating same vlan bridge on top of bond bridge. Fix: Call `Interface.bring_down` and `Interface.set_ipv4_conf` to None for all vlan bridges too. Signed-off-by: Sharad Yadav --- networkd/network_server.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 0033ac808..7857d0cda 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -638,13 +638,15 @@ module Bridge = struct Interface.bring_down () dbg ~name; match !backend_kind with | Openvswitch -> - if Ovs.get_vlans name = [] || force then begin + let vlans_on_this_parent = Ovs.get_vlans name in + if vlans_on_this_parent = [] || force then begin debug "Destroying bridge %s" name; remove_config name; + let interfaces = (Ovs.bridge_to_interfaces name) @ vlans_on_this_parent in List.iter (fun dev -> Interface.set_ipv4_conf () dbg ~name:dev ~conf:None4; Interface.bring_down () dbg ~name:dev - ) (Ovs.bridge_to_interfaces name); + ) interfaces; Interface.set_ipv4_conf () dbg ~name ~conf:None4; ignore (Ovs.destroy_bridge name) end else From 16ca407b83a8e05357960923bc82554c4c1cb286 Mon Sep 17 00:00:00 2001 From: Sharad Yadav Date: Wed, 17 May 2017 13:10:19 +0100 Subject: [PATCH 145/260] CA-254379: Fixing vlan bridge create during host installation. Host installer doesn't write management_interface into inventory. As firstboot needs to create management pif and update the inventory. In case of management on vlan xcp-networkd must not create vlan bridge if management_interface is empty. Let the firstboot create the VLAN and set the management PIF. Signed-off-by: Sharad Yadav --- lib/network_config.ml | 32 ++++++++++++++++++-------------- 1 file changed, 18 insertions(+), 14 deletions(-) diff --git a/lib/network_config.ml b/lib/network_config.ml index ebc0067c6..4c95d00e6 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -76,20 +76,24 @@ let read_management_conf () = ports = [device, {default_port with interfaces = [device]}]; persistent_b = true } in - match vlan with - | None -> - [device, phy_interface; bridge_name, bridge_interface], - [bridge_name, primary_bridge_conf] - | Some vlan -> - let parent = bridge_naming_convention device in - let secondary_bridge_conf = {default_bridge with - vlan = Some (parent, int_of_string vlan); - bridge_mac = (Some mac); - persistent_b = true - } in - let parent_bridge_interface = {default_interface with persistent_i = true} in - [device, phy_interface; parent, parent_bridge_interface; bridge_name, bridge_interface], - [parent, primary_bridge_conf; bridge_name, secondary_bridge_conf] + if bridge_name = "" then + [], [] + else begin + match vlan with + | None -> + [device, phy_interface; bridge_name, bridge_interface], + [bridge_name, primary_bridge_conf] + | Some vlan -> + let parent = bridge_naming_convention device in + let secondary_bridge_conf = {default_bridge with + vlan = Some (parent, int_of_string vlan); + bridge_mac = (Some mac); + persistent_b = true + } in + let parent_bridge_interface = {default_interface with persistent_i = true} in + [device, phy_interface; parent, parent_bridge_interface; bridge_name, bridge_interface], + [parent, primary_bridge_conf; bridge_name, secondary_bridge_conf] + end in {interface_config = interface_config; bridge_config = bridge_config; gateway_interface = Some bridge_name; dns_interface = Some bridge_name} From 637db5880c6def03521f3379afe80282af63061a Mon Sep 17 00:00:00 2001 From: sharad yadav Date: Fri, 26 May 2017 07:42:08 +0100 Subject: [PATCH 146/260] CA-244087: Update dhclient interface conf on changing default gateway. xcp-networkd must stop and start the dhclient for the interface if default gateway has changed. Example: 1) If default gateway is xenbr0 - Its conf file will keep this gateway information. 2) Switch the default gateway to xenbr1 - Its conf file will be created with gateway information. 3) Switch the default gateway back to xenbr0 then dhclient won't get restarted. Reason: 1) While switching default gateway from xenbr0 to xenbr1, gateway information from xenbr0 conf file was not removed. 2) On switching default gateway from xenbr1 to xenbr0, xcp-networkd found no diff in conf file hence not retarted the dhclient for xenbr0. It resulted default gateway still pointed to xenbr1. Signed-off-by: sharad yadav --- networkd/network_server.ml | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 7857d0cda..0adf7a6d3 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -79,6 +79,19 @@ let reset_state _ () = config := Network_config.read_management_conf () let set_gateway_interface _ dbg ~name = + (* Update dhclient conf for interface on changing default gateway. + * If new default gateway is not same as gateway_interface from networkd.db then + * we need to remove gateway information from gateway_interface *) + begin match !config.gateway_interface with + | Some gateway_iface when name <> gateway_iface -> + let opts = + match !config.dns_interface with + | Some dns_iface when gateway_iface = dns_iface -> [`set_dns] + | _ -> [] + in + Dhclient.write_conf_file gateway_iface opts + | _ -> () + end; debug "Setting gateway interface to %s" name; config := {!config with gateway_interface = Some name} From deebde45df716643a60579638e295dcc5bf637c4 Mon Sep 17 00:00:00 2001 From: Liang Dai Date: Thu, 11 May 2017 19:33:50 +0800 Subject: [PATCH 147/260] CP-20569: Enable OVS IGMP Snooping by default Signed-off-by: Liang Dai --- lib/network_utils.ml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index b750482db..d4d228656 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -917,8 +917,14 @@ module Ovs = struct else [] in + let set_mcast_snooping = + if vlan = None then + ["--"; "set"; "bridge"; name; "mcast_snooping_enable=true"] + else + [] + in vsctl ~log:true (del_old_arg @ ["--"; "--may-exist"; "add-br"; name] @ - vlan_arg @ mac_arg @ fail_mode_arg @ disable_in_band_arg @ external_id_arg @ vif_arg @ set_mac_table_size) + vlan_arg @ mac_arg @ fail_mode_arg @ disable_in_band_arg @ external_id_arg @ vif_arg @ set_mac_table_size @ set_mcast_snooping) let destroy_bridge name = vsctl ~log:true ["--"; "--if-exists"; "del-br"; name] From 82bc39b76eb13b6a3a073a34d342ae42facca71c Mon Sep 17 00:00:00 2001 From: Liang Dai Date: Wed, 26 Jul 2017 10:41:52 +0800 Subject: [PATCH 148/260] CP-23093: Implement toggle of IGMP snooping on xcp-networkd Signed-off-by: Liang Dai --- lib/network_utils.ml | 12 +++++------- networkd/network_server.ml | 10 +++++----- 2 files changed, 10 insertions(+), 12 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index d4d228656..5bd2e08ec 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -867,7 +867,7 @@ module Ovs = struct with _ -> ()); ) phy_interfaces - let create_bridge ?mac ?external_id ?disable_in_band ~fail_mode vlan vlan_bug_workaround name = + let create_bridge ?mac ?external_id ?disable_in_band ?igmp_snooping ~fail_mode vlan vlan_bug_workaround name = let vlan_arg = match vlan with | None -> [] | Some (parent, tag) -> @@ -917,14 +917,12 @@ module Ovs = struct else [] in - let set_mcast_snooping = - if vlan = None then - ["--"; "set"; "bridge"; name; "mcast_snooping_enable=true"] - else - [] + let set_igmp_snooping = match igmp_snooping, vlan with + | Some x, None -> ["--"; "set"; "bridge"; name; "mcast_snooping_enable=" ^ (string_of_bool x)] + | _ -> [] in vsctl ~log:true (del_old_arg @ ["--"; "--may-exist"; "add-br"; name] @ - vlan_arg @ mac_arg @ fail_mode_arg @ disable_in_band_arg @ external_id_arg @ vif_arg @ set_mac_table_size @ set_mcast_snooping) + vlan_arg @ mac_arg @ fail_mode_arg @ disable_in_band_arg @ external_id_arg @ vif_arg @ set_mac_table_size @ set_igmp_snooping) let destroy_bridge name = vsctl ~log:true ["--"; "--if-exists"; "del-br"; name] diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 0adf7a6d3..e64ac9c5f 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -546,14 +546,14 @@ module Bridge = struct ) existing_bridges end - let create _ dbg ?vlan ?mac ?(other_config=[]) ~name () = + let create _ dbg ?vlan ?mac ?igmp_snooping ?(other_config=[]) ~name () = Debug.with_thread_associated dbg (fun () -> debug "Creating bridge %s%s" name (match vlan with | None -> "" | Some (parent, vlan) -> Printf.sprintf " (VLAN %d on bridge %s)" vlan parent ); Stdext.Opt.iter (destroy_existing_vlan_bridge name) vlan; - update_config name {(get_config name) with vlan; bridge_mac=mac; other_config}; + update_config name {(get_config name) with vlan; bridge_mac=mac; igmp_snooping; other_config}; begin match !backend_kind with | Openvswitch -> let fail_mode = @@ -595,7 +595,7 @@ module Bridge = struct (debug "%s isn't a valid setting for other_config:vswitch-disable-in-band" dib; None) in - ignore (Ovs.create_bridge ?mac ~fail_mode ?external_id ?disable_in_band + ignore (Ovs.create_bridge ?mac ~fail_mode ?external_id ?disable_in_band ?igmp_snooping vlan vlan_bug_workaround name) | Bridge -> ignore (Brctl.create_bridge name); @@ -983,10 +983,10 @@ module Bridge = struct debug "** Configuring the following bridges: %s%s" (String.concat ", " (List.map (fun (name, _) -> name) config)) (if conservative then " (best effort)" else ""); - List.iter (function (bridge_name, ({ports; vlan; bridge_mac; other_config; _} as c)) -> + List.iter (function (bridge_name, ({ports; vlan; bridge_mac; igmp_snooping; other_config; _} as c)) -> update_config bridge_name c; exec (fun () -> - create () dbg ?vlan ?mac:bridge_mac ~other_config ~name:bridge_name (); + create () dbg ?vlan ?mac:bridge_mac ?igmp_snooping ~other_config ~name:bridge_name (); List.iter (fun (port_name, {interfaces; bond_properties; bond_mac; kind}) -> add_port () dbg ?bond_mac ~bridge:bridge_name ~name:port_name ~interfaces ~bond_properties ~kind () ) ports From cda0ebc8bc28256e867ba547570a391e31744ec3 Mon Sep 17 00:00:00 2001 From: Yarsin He Date: Wed, 16 Aug 2017 18:39:14 +0800 Subject: [PATCH 149/260] CP-23601 Inject IGMP snooping query message when IGMP snooping toggle In this change, when setting IGMP snooping toggle mcast_snooping_enable in OVS, if the current setting is off but new setting is on, then a script will be called to inject a IGMP query into the bridge (each vif interface), for quicker adaption to IGMP for applications in VMs. A tunable configuration field igmp-query-maxresp-time is added, for maximum responsible time of the injected query, default to be at 5000ms. Signed-off-by: Yarsin He --- lib/network_utils.ml | 14 ++++++++++++++ networkd/network_server.ml | 6 +++++- networkd/networkd.ml | 7 +++++++ 3 files changed, 26 insertions(+), 1 deletion(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 5bd2e08ec..1a41fcf8d 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -35,7 +35,9 @@ let modprobe = "/sbin/modprobe" let ethtool = ref "/sbin/ethtool" let bonding_dir = "/proc/net/bonding/" let fcoedriver = ref "/opt/xensource/libexec/fcoe_driver" +let inject_igmp_query_script = ref "/usr/libexec/xenopsd/igmp_query_injector.py" let mac_table_size = ref 10000 +let igmp_query_maxresp_time = ref "5000" let call_script ?(log_successful_output=false) ?(timeout=Some 60.0) script args = try @@ -867,6 +869,18 @@ module Ovs = struct with _ -> ()); ) phy_interfaces + let get_mcast_snooping_enable ~name = + try + vsctl ~log:true ["--"; "get"; "bridge"; name; "mcast_snooping_enable"] + |> String.rtrim + |> bool_of_string + with _ -> false + + let inject_igmp_query ~name = + try + ignore (call_script ~log_successful_output:true !inject_igmp_query_script ["--detach"; "--max-resp-time"; !igmp_query_maxresp_time; "bridge"; name]) + with _ -> () + let create_bridge ?mac ?external_id ?disable_in_band ?igmp_snooping ~fail_mode vlan vlan_bug_workaround name = let vlan_arg = match vlan with | None -> [] diff --git a/networkd/network_server.ml b/networkd/network_server.ml index e64ac9c5f..80d186fcc 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -595,8 +595,12 @@ module Bridge = struct (debug "%s isn't a valid setting for other_config:vswitch-disable-in-band" dib; None) in + let old_igmp_snooping = Ovs.get_mcast_snooping_enable name in ignore (Ovs.create_bridge ?mac ~fail_mode ?external_id ?disable_in_band ?igmp_snooping - vlan vlan_bug_workaround name) + vlan vlan_bug_workaround name); + if igmp_snooping = Some true && not old_igmp_snooping then + Ovs.inject_igmp_query name + | Bridge -> ignore (Brctl.create_bridge name); Brctl.set_forwarding_delay name 0; diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 30b589872..9752c55e8 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -47,6 +47,12 @@ let resources = [ essential = false; path = Network_utils.fcoedriver; perms = [ Unix.X_OK ]; + }; + { Xcp_service.name = "inject-igmp-query-script"; + description = "used to inject an IGMP query message for a bridge"; + essential = false; + path = Network_utils.inject_igmp_query_script; + perms = [ Unix.X_OK ]; } ] @@ -55,6 +61,7 @@ let options = [ "mac-table-size", Arg.Set_int Network_utils.mac_table_size, (fun () -> string_of_int !Network_utils.mac_table_size), "Default value for the mac-table-size openvswitch parameter (see ovs-vswitchd.conf.db.5)"; "enic-workaround-until-version", Arg.Set_string Network_server.enic_workaround_until_version, (fun () -> !Network_server.enic_workaround_until_version), "The version till enic driver workaround will be applied or the version set to an empty string for not applying the workaround."; "pvs-proxy-socket", Arg.Set_string Network_server.PVS_proxy.path, (fun () -> !Network_server.PVS_proxy.path), "Path to the Unix domain socket for the PVS-proxy daemon"; + "igmp-query-maxresp-time", Arg.Set_string Network_utils.igmp_query_maxresp_time, (fun () -> !Network_utils.igmp_query_maxresp_time), "Maximum Response Time in IGMP Query message to send"; ] let start server = From edf8bcf83a541295621c5a152797b010e652d293 Mon Sep 17 00:00:00 2001 From: Yang Qian Date: Thu, 17 Aug 2017 11:10:58 +0800 Subject: [PATCH 150/260] CP-23843: Disable IPv6 multicast snooping for OVS in XenServer Signed-off-by: Yang Qian --- lib/network_utils.ml | 7 ++++++- networkd/networkd.ml | 1 + 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 1a41fcf8d..0ccb28797 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -38,6 +38,7 @@ let fcoedriver = ref "/opt/xensource/libexec/fcoe_driver" let inject_igmp_query_script = ref "/usr/libexec/xenopsd/igmp_query_injector.py" let mac_table_size = ref 10000 let igmp_query_maxresp_time = ref "5000" +let enable_ipv6_mcast_snooping = ref false let call_script ?(log_successful_output=false) ?(timeout=Some 60.0) script args = try @@ -935,8 +936,12 @@ module Ovs = struct | Some x, None -> ["--"; "set"; "bridge"; name; "mcast_snooping_enable=" ^ (string_of_bool x)] | _ -> [] in + let set_ipv6_igmp_snooping = match igmp_snooping, vlan with + | Some _, None -> ["--"; "set"; "bridge"; name; "other_config:enable-ipv6-mcast-snooping=" ^ (string_of_bool !enable_ipv6_mcast_snooping)] + | _ -> [] + in vsctl ~log:true (del_old_arg @ ["--"; "--may-exist"; "add-br"; name] @ - vlan_arg @ mac_arg @ fail_mode_arg @ disable_in_band_arg @ external_id_arg @ vif_arg @ set_mac_table_size @ set_igmp_snooping) + vlan_arg @ mac_arg @ fail_mode_arg @ disable_in_band_arg @ external_id_arg @ vif_arg @ set_mac_table_size @ set_igmp_snooping @ set_ipv6_igmp_snooping) let destroy_bridge name = vsctl ~log:true ["--"; "--if-exists"; "del-br"; name] diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 9752c55e8..f85eab9ab 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -62,6 +62,7 @@ let options = [ "enic-workaround-until-version", Arg.Set_string Network_server.enic_workaround_until_version, (fun () -> !Network_server.enic_workaround_until_version), "The version till enic driver workaround will be applied or the version set to an empty string for not applying the workaround."; "pvs-proxy-socket", Arg.Set_string Network_server.PVS_proxy.path, (fun () -> !Network_server.PVS_proxy.path), "Path to the Unix domain socket for the PVS-proxy daemon"; "igmp-query-maxresp-time", Arg.Set_string Network_utils.igmp_query_maxresp_time, (fun () -> !Network_utils.igmp_query_maxresp_time), "Maximum Response Time in IGMP Query message to send"; + "enable-ipv6-mcast-snooping", Arg.Bool (fun x -> Network_utils.enable_ipv6_mcast_snooping := x), (fun () -> string_of_bool !Network_utils.enable_ipv6_mcast_snooping), "IPv6 multicast snooping toggle"; ] let start server = From 89f79533e0a88500d11702b95b2490236ca98fa3 Mon Sep 17 00:00:00 2001 From: minglumlu Date: Tue, 15 Aug 2017 07:19:19 +0100 Subject: [PATCH 151/260] CP-23835: Disable flooding of unregistered traffic Signed-off-by: Ming Lu Signed-off-by: Yang Qian --- lib/network_utils.ml | 8 +++++++- networkd/networkd.ml | 1 + 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 0ccb28797..d6d2dc6ef 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -39,6 +39,7 @@ let inject_igmp_query_script = ref "/usr/libexec/xenopsd/igmp_query_injector.py" let mac_table_size = ref 10000 let igmp_query_maxresp_time = ref "5000" let enable_ipv6_mcast_snooping = ref false +let mcast_snooping_disable_flood_unregistered = ref true let call_script ?(log_successful_output=false) ?(timeout=Some 60.0) script args = try @@ -940,8 +941,13 @@ module Ovs = struct | Some _, None -> ["--"; "set"; "bridge"; name; "other_config:enable-ipv6-mcast-snooping=" ^ (string_of_bool !enable_ipv6_mcast_snooping)] | _ -> [] in + let disable_flood_unregistered = match igmp_snooping, vlan with + | Some _, None -> + ["--"; "set"; "bridge"; name; "other_config:mcast-snooping-disable-flood-unregistered=" ^ (string_of_bool !mcast_snooping_disable_flood_unregistered)] + | _ -> [] + in vsctl ~log:true (del_old_arg @ ["--"; "--may-exist"; "add-br"; name] @ - vlan_arg @ mac_arg @ fail_mode_arg @ disable_in_band_arg @ external_id_arg @ vif_arg @ set_mac_table_size @ set_igmp_snooping @ set_ipv6_igmp_snooping) + vlan_arg @ mac_arg @ fail_mode_arg @ disable_in_band_arg @ external_id_arg @ vif_arg @ set_mac_table_size @ set_igmp_snooping @ set_ipv6_igmp_snooping @ disable_flood_unregistered) let destroy_bridge name = vsctl ~log:true ["--"; "--if-exists"; "del-br"; name] diff --git a/networkd/networkd.ml b/networkd/networkd.ml index f85eab9ab..9a57a1e11 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -63,6 +63,7 @@ let options = [ "pvs-proxy-socket", Arg.Set_string Network_server.PVS_proxy.path, (fun () -> !Network_server.PVS_proxy.path), "Path to the Unix domain socket for the PVS-proxy daemon"; "igmp-query-maxresp-time", Arg.Set_string Network_utils.igmp_query_maxresp_time, (fun () -> !Network_utils.igmp_query_maxresp_time), "Maximum Response Time in IGMP Query message to send"; "enable-ipv6-mcast-snooping", Arg.Bool (fun x -> Network_utils.enable_ipv6_mcast_snooping := x), (fun () -> string_of_bool !Network_utils.enable_ipv6_mcast_snooping), "IPv6 multicast snooping toggle"; + "mcast-snooping-disable-flood-unregistered", Arg.Bool (fun x -> Network_utils.mcast_snooping_disable_flood_unregistered := x), (fun () -> string_of_bool !Network_utils.mcast_snooping_disable_flood_unregistered), "Set OVS bridge configuration mcast-snooping-disable-flood-unregistered as 'true' or 'false'"; ] let start server = From e8f23ec7b94850050c219555a73499e6be9b5f8f Mon Sep 17 00:00:00 2001 From: YarsinCitrix Date: Mon, 18 Sep 2017 17:54:54 +0800 Subject: [PATCH 152/260] CA-264980: Fork/exec igmp_query_injector.py and let it run in the background Signed-off-by: Yarsin He --- lib/network_utils.ml | 81 +++++++++++++++++++++++++++++--------------- 1 file changed, 53 insertions(+), 28 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index d6d2dc6ef..66ff95110 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -41,14 +41,13 @@ let igmp_query_maxresp_time = ref "5000" let enable_ipv6_mcast_snooping = ref false let mcast_snooping_disable_flood_unregistered = ref true -let call_script ?(log_successful_output=false) ?(timeout=Some 60.0) script args = +let check_n_run run_func script args = try Unix.access script [ Unix.X_OK ]; (* Use the same $PATH as xapi *) let env = [| "PATH=" ^ (Sys.getenv "PATH") |] in info "%s %s" script (String.concat " " args); - let (out,err) = Forkhelpers.execute_command_get_output ~env ?timeout script args in - out + run_func env script args with | Unix.Unix_error (e, a, b) -> error "Caught unix error: %s [%s, %s]" (Unix.error_message e) a b; @@ -66,6 +65,20 @@ let call_script ?(log_successful_output=false) ?(timeout=Some 60.0) script args raise (Script_error ["script", script; "args", String.concat " " args; "code", message; "stdout", stdout; "stderr", stderr]) +let call_script ?(log_successful_output=false) ?(timeout=Some 60.0) script args = + let call_script_internal env script args = + let (out,err) = Forkhelpers.execute_command_get_output ~env ?timeout script args in + out + in + check_n_run call_script_internal script args + +let fork_script script args = + let fork_script_internal env script args = + let pid = Forkhelpers.safe_close_and_exec ~env None None None [] script args in + Forkhelpers.dontwaitpid pid; + in + check_n_run fork_script_internal script args + module Sysfs = struct let list () = let all = Array.to_list (Sys.readdir "/sys/class/net") in @@ -871,6 +884,37 @@ module Ovs = struct with _ -> ()); ) phy_interfaces + let get_vlans name = + try + let vlans_with_uuid = + let raw = vsctl ["--bare"; "-f"; "table"; "--"; "--columns=name,_uuid"; "find"; "port"; "fake_bridge=true"] in + if raw <> "" then + let lines = String.split '\n' (String.rtrim raw) in + List.map (fun line -> Scanf.sscanf line "%s %s" (fun a b-> a, b)) lines + else + [] + in + let bridge_ports = + let raw = vsctl ["get"; "bridge"; name; "ports"] in + let raw = String.rtrim raw in + if raw <> "[]" then + let raw_list = (String.split ',' (String.sub raw 1 (String.length raw - 2))) in + List.map (String.strip String.isspace) raw_list + else + [] + in + let vlans_on_bridge = List.filter (fun (_, br) -> List.mem br bridge_ports) vlans_with_uuid in + List.map (fun (n, _) -> n) vlans_on_bridge + with _ -> [] + + let get_bridge_vlan_vifs ~name = + try + let vlan_fake_bridges = get_vlans name in + List.fold_left(fun vifs br -> + let vifs' = bridge_to_interfaces br in + vifs' @ vifs) [] vlan_fake_bridges + with _ -> [] + let get_mcast_snooping_enable ~name = try vsctl ~log:true ["--"; "get"; "bridge"; name; "mcast_snooping_enable"] @@ -880,8 +924,12 @@ module Ovs = struct let inject_igmp_query ~name = try - ignore (call_script ~log_successful_output:true !inject_igmp_query_script ["--detach"; "--max-resp-time"; !igmp_query_maxresp_time; "bridge"; name]) - with _ -> () + let vvifs = get_bridge_vlan_vifs name in + let bvifs = bridge_to_interfaces name in + let bvifs' = List.filter(fun vif -> Xstringext.String.startswith "vif" vif) bvifs in + (* The vifs may be large. However considering current XS limit of 1000VM*7NIC/VM + 800VLANs, the buffer of CLI should be sufficient for lots of vifxxxx.xx *) + fork_script !inject_igmp_query_script (["--no-check-snooping-toggle"; "--max-resp-time"; !igmp_query_maxresp_time] @ bvifs' @ vvifs) + with _ -> () let create_bridge ?mac ?external_id ?disable_in_band ?igmp_snooping ~fail_mode vlan vlan_bug_workaround name = let vlan_arg = match vlan with @@ -959,29 +1007,6 @@ module Ovs = struct else [] - let get_vlans name = - try - let vlans_with_uuid = - let raw = vsctl ["--bare"; "-f"; "table"; "--"; "--columns=name,_uuid"; "find"; "port"; "fake_bridge=true"] in - if raw <> "" then - let lines = String.split '\n' (String.rtrim raw) in - List.map (fun line -> Scanf.sscanf line "%s %s" (fun a b-> a, b)) lines - else - [] - in - let bridge_ports = - let raw = vsctl ["get"; "bridge"; name; "ports"] in - let raw = String.rtrim raw in - if raw <> "[]" then - let raw_list = (String.split ',' (String.sub raw 1 (String.length raw - 2))) in - List.map (String.strip String.isspace) raw_list - else - [] - in - let vlans_on_bridge = List.filter (fun (_, br) -> List.mem br bridge_ports) vlans_with_uuid in - List.map (fun (n, _) -> n) vlans_on_bridge - with _ -> [] - let create_port ?(internal=false) name bridge = let type_args = if internal then ["--"; "set"; "interface"; name; "type=internal"] else [] in From ed2151f8d82d178b39c2254ae1ed84eac120fc01 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 4 Oct 2017 15:05:50 +0100 Subject: [PATCH 153/260] CA-196520: use mtu_request in OVS to set interface MTU MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit If `ip link set` is used OVS will keep changing it back to the default MTU. Signed-off-by: Edwin Török --- lib/network_utils.ml | 3 +++ networkd/network_server.ml | 4 +++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 66ff95110..4c4e42690 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -1119,6 +1119,9 @@ module Ovs = struct let mod_port bridge port action = ofctl ~log:true ["mod-port"; bridge; port; action] |> ignore + let set_mtu interface mtu = + vsctl ~log:true ["set"; "interface"; interface; Printf.sprintf "mtu_request=%d" mtu] + end include Make(Cli) end diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 80d186fcc..ed7405f6a 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -346,7 +346,9 @@ module Interface = struct Debug.with_thread_associated dbg (fun () -> debug "Configuring MTU for %s: %d" name mtu; update_config name {(get_config name) with mtu}; - ignore (Ip.link_set_mtu name mtu) + match !backend_kind with + | Openvswitch -> ignore (Ovs.set_mtu name mtu) + | Bridge -> Ip.link_set_mtu name mtu ) () let set_ethtool_settings _ dbg ~name ~params = From 31fe3b73a41fd7053d92fd2b34f4bb7dcdd1cb57 Mon Sep 17 00:00:00 2001 From: Yang Qian Date: Thu, 12 Oct 2017 17:21:21 +0800 Subject: [PATCH 154/260] CA-268679 XAPI loop report (Sys_error "Invalid argument") When reading attributes from the net device which is off, kernel will return with EINVAL. Refer to: https://unix.stackexchange.com/questions/190967/reading-from-sysfs-returns-einval In order to avoid the annoying error: Match Sys_error("Invalid argument") and omit the error log. For other error case, record the exception info and backtrace. Signed-off-by: Yang Qian --- lib/network_utils.ml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 4c4e42690..d4ad079d3 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -109,7 +109,12 @@ module Sysfs = struct (fun () -> close_in inchan) with | End_of_file -> "" - | exn -> error "%s" (Printexc.to_string exn); raise (Read_error file) + (* Match the exception when the device state if off *) + | Sys_error("Invalid argument") -> raise (Read_error file) + | exn -> + error "Error in read one line of file: %s, exception %s\n%s" + file (Printexc.to_string exn) (Printexc.get_backtrace ()); + raise (Read_error file) let write_one_line file l = let outchan = open_out file in From f39d410407ff91c820db04f2edbc7139d7798ce6 Mon Sep 17 00:00:00 2001 From: Yarsin He Date: Thu, 7 Dec 2017 14:11:31 +0000 Subject: [PATCH 155/260] CP-26156: Port xcp-networkd to use jbuilder --- .gitignore | 2 + Makefile | 69 +- _oasis | 101 - _tags | 132 - _tags.coverage | 6 - cli/jbuild | 14 + jbuild | 1 + lib/META | 13 - lib/jbuild | 15 + lib/libnetworklibs_stubs.clib | 4 - lib/networklibs.mldylib | 6 - lib/networklibs.mllib | 6 - myocamlbuild.ml | 513 --- networkd/jbuild | 41 + networkd_db/jbuild | 13 + opam | 17 - profiling/META | 11 - profiling/coverage.mldylib | 4 - profiling/coverage.mllib | 4 - profiling/jbuild | 8 + profiling/profiling.mldylib | 4 - profiling/profiling.mllib | 4 - setup.ml | 6071 --------------------------------- test/jbuild | 13 + 24 files changed, 126 insertions(+), 6946 deletions(-) delete mode 100644 _oasis delete mode 100644 _tags delete mode 100644 _tags.coverage create mode 100644 cli/jbuild create mode 100644 jbuild delete mode 100644 lib/META create mode 100644 lib/jbuild delete mode 100644 lib/libnetworklibs_stubs.clib delete mode 100644 lib/networklibs.mldylib delete mode 100644 lib/networklibs.mllib delete mode 100644 myocamlbuild.ml create mode 100644 networkd/jbuild create mode 100644 networkd_db/jbuild delete mode 100644 opam delete mode 100644 profiling/META delete mode 100644 profiling/coverage.mldylib delete mode 100644 profiling/coverage.mllib create mode 100644 profiling/jbuild delete mode 100644 profiling/profiling.mldylib delete mode 100644 profiling/profiling.mllib delete mode 100644 setup.ml create mode 100644 test/jbuild diff --git a/.gitignore b/.gitignore index 8f1bb8547..2e3f30293 100644 --- a/.gitignore +++ b/.gitignore @@ -6,5 +6,7 @@ xcp-networkd.1 *.native setup.data setup.log +*.merlin +*.install dist/ _build/ diff --git a/Makefile b/Makefile index 8811a1839..c20a837ab 100644 --- a/Makefile +++ b/Makefile @@ -1,67 +1,36 @@ BINDIR ?= /usr/bin SBINDIR ?= /usr/sbin -ETCDIR ?= /etc MANDIR ?= /usr/share/man/man1 -all: build doc -.PHONY: test install uninstall clean +.PHONY: build release install uninstall clean test doc reindent -export OCAMLRUNPARAM=b -J=4 +build: + jbuilder build @networkd/man @install --dev -setup.bin: setup.ml - @ocamlopt.opt -o $@ $< || ocamlopt -o $@ $< || ocamlc -o $@ $< - @rm -f setup.cmx setup.cmi setup.o setup.cmo - -setup.data: setup.bin - @./setup.bin -configure --enable-tests - -build: setup.data setup.bin networkd/version.ml - @./setup.bin -build -j $(J) - mv networkd.native xcp-networkd - ./xcp-networkd --help=groff > xcp-networkd.1 - -networkd/version.ml: VERSION - echo "let version = \"$(shell cat VERSION)\"" > networkd/version.ml - -doc: setup.data setup.bin - @./setup.bin -doc -j $(J) - -test: setup.bin build - @./setup.bin -test +release: + jbuilder build @install install: mkdir -p $(DESTDIR)$(SBINDIR) - install xcp-networkd $(DESTDIR)$(SBINDIR)/xcp-networkd + cp _build/default/networkd/networkd.exe $(DESTDIR)$(SBINDIR)/xcp-networkd mkdir -p $(DESTDIR)$(MANDIR) - install xcp-networkd.1 $(DESTDIR)$(MANDIR)/xcp-networkd.1 + cp _build/default/networkd/xcp-networkd.1 $(DESTDIR)$(MANDIR)/xcp-networkd.1 mkdir -p $(DESTDIR)$(BINDIR) - install networkd_db.native $(DESTDIR)$(BINDIR)/networkd_db + cp _build/default/networkd_db/networkd_db.exe $(DESTDIR)$(BINDIR)/networkd_db uninstall: - rm -f $(DESTDIR)$(SBINDIR)/xcp-networkd - rm -f $(DESTDIR)$(MANDIR)/xcp-networkd.1 - rm -f $(DESTDIR)$(SBINDIR)/networkd_db - + rm -f $(DESTDIR)$(SBINDIR)/xcp-networkd + rm -f $(DESTDIR)$(MANDIR)/xcp-networkd.1 + rm -f $(DESTDIR)$(SBINDIR)/networkd_db clean: - @ocamlbuild -clean - @rm -f setup.data setup.log setup.bin - rm networkd/version.ml - rm xcp-networkd.1 - - -# make coverage - prepares for building with coverage analysis -# make uncover - reverses the setup from "make coverage" -# make report - create coverage/index.html - -coverage: _tags _tags.coverage - test ! -f _tags.orig && mv _tags _tags.orig || true - cat _tags.coverage _tags.orig > _tags + jbuilder clean -uncover: _tags.orig - mv _tags.orig _tags +test: + _build/default/test/network_test.exe -report: - bisect-ppx-report -I _build -html coverage /tmp/bisect-network*out +# requires odoc +doc: + jbuilder build @doc -.PHONY: report coverage uncover +reindent: + ocp-indent --inplace **/*.ml* diff --git a/_oasis b/_oasis deleted file mode 100644 index 5d25036b3..000000000 --- a/_oasis +++ /dev/null @@ -1,101 +0,0 @@ -OASISFormat: 0.3 -Name: xcp-networkd -Version: 0.10.0 -Synopsis: XCP Network Daemon -Authors: Rob Hoes -License: LGPL-2.1 with OCaml linking exception -Plugins: META (0.2) -BuildTools: ocamlbuild - -Library profiling - CompiledObject: best - Path: profiling - Install: false - Modules: Coverage - BuildDepends: - -Library networklibs - CompiledObject: best - Path: lib - Findlibname: network-libs - Modules: Network_config, Network_utils, Jsonrpc_client - BuildDepends: - forkexec, - stdext, - threads, - rpclib, - stdext, - xcp-inventory, - xcp.network, - systemd - -Executable xcp_networkd - CompiledObject: best - Path: networkd - MainIs: networkd.ml - Custom: true - Install: false - BuildDepends: - profiling, - threads, - rpclib, - rpclib.unix, - forkexec, - stdext, - xcp-inventory, - network-libs, - xen-api-client, - xcp, - xcp.network, - netlink, - systemd - -Executable networkd_db - CompiledObject: best - Path: networkd_db - MainIs: networkd_db.ml - Custom: true - Install: false - BuildDepends: - profiling, - network-libs, - stdext, - threads, - xcp.network - -Executable network_test - CompiledObject: best - Path: test - MainIs: network_test.ml - Install: false - BuildDepends: - profiling, - stdext, - oUnit, - network-libs, - xapi-test-utils - -Test test_networkd - Run$: flag(tests) - Command: $network_test - WorkingDirectory: . - -Executable cli - CompiledObject: best - Path: cli - MainIs: network_cli.ml - BuildDepends: - profiling, - cmdliner, - stdext, - network-libs, - xcp, - xcp.network - -Executable jsonrpc_dummy - CompiledObject: best - Path: test - MainIs: jsonrpc_dummy.ml - Install: false - BuildDepends: - network-libs diff --git a/_tags b/_tags deleted file mode 100644 index cc62a4d35..000000000 --- a/_tags +++ /dev/null @@ -1,132 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 2e20ef321d942788d2374e5ecfec8300) -# 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 -<**/.svn>: -traverse -<**/.svn>: not_hygienic -".bzr": -traverse -".bzr": not_hygienic -".hg": -traverse -".hg": not_hygienic -".git": -traverse -".git": not_hygienic -"_darcs": -traverse -"_darcs": not_hygienic -# Library profiling -"profiling/profiling.cmxs": use_profiling -# Library networklibs -"lib/networklibs.cmxs": use_networklibs -: oasis_library_networklibs_ccopt -: pkg_stdext -: pkg_xcp.network -: pkg_threads -: pkg_rpclib -: pkg_forkexec -: pkg_xcp-inventory -: pkg_systemd -# Executable xcp_networkd -: use_profiling -: use_networklibs -: pkg_stdext -: pkg_xcp -: pkg_xcp.network -: pkg_threads -: pkg_rpclib -: pkg_rpclib.unix -: pkg_forkexec -: pkg_xcp-inventory -: pkg_xen-api-client -: pkg_netlink -: pkg_systemd -: use_profiling -: use_networklibs -: pkg_stdext -: pkg_xcp -: pkg_xcp.network -: pkg_threads -: pkg_rpclib -: pkg_rpclib.unix -: pkg_forkexec -: pkg_xcp-inventory -: pkg_xen-api-client -: pkg_netlink -: pkg_systemd -: custom -# Executable networkd_db -: use_profiling -: use_networklibs -: pkg_stdext -: pkg_xcp.network -: pkg_threads -: pkg_rpclib -: pkg_forkexec -: pkg_xcp-inventory -: pkg_systemd -: use_profiling -: use_networklibs -: pkg_stdext -: pkg_xcp.network -: pkg_threads -: pkg_rpclib -: pkg_forkexec -: pkg_xcp-inventory -: pkg_systemd -: custom -# Executable network_test -: use_profiling -: use_networklibs -: pkg_stdext -: pkg_xcp.network -: pkg_oUnit -: pkg_xapi-test-utils -: pkg_threads -: pkg_rpclib -: pkg_forkexec -: pkg_xcp-inventory -: pkg_systemd -: use_profiling -: pkg_oUnit -: pkg_xapi-test-utils -# Executable cli -: use_profiling -: use_networklibs -: pkg_cmdliner -: pkg_stdext -: pkg_xcp -: pkg_xcp.network -: pkg_threads -: pkg_rpclib -: pkg_forkexec -: pkg_xcp-inventory -: pkg_systemd -: use_profiling -: use_networklibs -: pkg_cmdliner -: pkg_stdext -: pkg_xcp -: pkg_xcp.network -: pkg_threads -: pkg_rpclib -: pkg_forkexec -: pkg_xcp-inventory -: pkg_systemd -# Executable jsonrpc_dummy -: use_networklibs -: pkg_stdext -: pkg_xcp.network -: pkg_threads -: pkg_rpclib -: pkg_forkexec -: pkg_xcp-inventory -: pkg_systemd -: use_networklibs -: pkg_stdext -: pkg_xcp.network -: pkg_threads -: pkg_rpclib -: pkg_forkexec -: pkg_xcp-inventory -: pkg_systemd -# OASIS_STOP - diff --git a/_tags.coverage b/_tags.coverage deleted file mode 100644 index 8c543834f..000000000 --- a/_tags.coverage +++ /dev/null @@ -1,6 +0,0 @@ -# START_COVERAGE -# coverage analysis with bisect_ppx -# compile and link with package bisect_ppx -<**/*.ml{,i,y}>: pkg_bisect_ppx -<**/*.native>: pkg_bisect_ppx -# END_COVERAGE diff --git a/cli/jbuild b/cli/jbuild new file mode 100644 index 000000000..26650f87c --- /dev/null +++ b/cli/jbuild @@ -0,0 +1,14 @@ +(executable + ((name network_cli) + (public_name networkd-cli) + (package xcp-networkd) + (flags (:standard -bin-annot -warn-error +a-6)) + (libraries (profiling + cmdliner + stdext + networklibs + xcp + xcp.network) + ) + ) +) diff --git a/jbuild b/jbuild new file mode 100644 index 000000000..265ed0a0a --- /dev/null +++ b/jbuild @@ -0,0 +1 @@ +(jbuild_version 1) \ No newline at end of file diff --git a/lib/META b/lib/META deleted file mode 100644 index 8bff2b223..000000000 --- a/lib/META +++ /dev/null @@ -1,13 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 15141d14f3a161ffac233e3e5d89f7eb) -version = "0.10.0" -description = "XCP Network Daemon" -requires = -"forkexec stdext threads rpclib stdext xcp-inventory xcp.network systemd" -archive(byte) = "networklibs.cma" -archive(byte, plugin) = "networklibs.cma" -archive(native) = "networklibs.cmxa" -archive(native, plugin) = "networklibs.cmxs" -exists_if = "networklibs.cma" -# OASIS_STOP - diff --git a/lib/jbuild b/lib/jbuild new file mode 100644 index 000000000..5163c8bb1 --- /dev/null +++ b/lib/jbuild @@ -0,0 +1,15 @@ +(jbuild_version 1) + +(library + ((name networklibs) + (flags (:standard :standard -bin-annot -warn-error +a-6-27-33-52)) + (libraries (forkexec + threads + rpclib + stdext + xcp-inventory + xcp.network + systemd)) + (wrapped false) + ) +) \ No newline at end of file diff --git a/lib/libnetworklibs_stubs.clib b/lib/libnetworklibs_stubs.clib deleted file mode 100644 index 4af8b9516..000000000 --- a/lib/libnetworklibs_stubs.clib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 2eec6769d0c3db5ab2748de2ec73c768) -link_stubs.o -# OASIS_STOP diff --git a/lib/networklibs.mldylib b/lib/networklibs.mldylib deleted file mode 100644 index 7ce259cfa..000000000 --- a/lib/networklibs.mldylib +++ /dev/null @@ -1,6 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 9ba8d589e3c2bbc8ad11518d00bef3df) -Network_config -Network_utils -Jsonrpc_client -# OASIS_STOP diff --git a/lib/networklibs.mllib b/lib/networklibs.mllib deleted file mode 100644 index 7ce259cfa..000000000 --- a/lib/networklibs.mllib +++ /dev/null @@ -1,6 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 9ba8d589e3c2bbc8ad11518d00bef3df) -Network_config -Network_utils -Jsonrpc_client -# OASIS_STOP diff --git a/myocamlbuild.ml b/myocamlbuild.ml deleted file mode 100644 index d1e7bacbf..000000000 --- a/myocamlbuild.ml +++ /dev/null @@ -1,513 +0,0 @@ -(* OASIS_START *) -(* DO NOT EDIT (digest: ab6e95fe4216607ba5333bd62a013f84) *) -module OASISGettext = struct -(* # 21 "src/oasis/OASISGettext.ml" *) - - let ns_ str = - str - - let s_ str = - str - - let f_ (str : ('a, 'b, 'c, 'd) format4) = - str - - let fn_ fmt1 fmt2 n = - if n = 1 then - fmt1^^"" - else - fmt2^^"" - - let init = - [] - -end - -module OASISExpr = struct -(* # 21 "src/oasis/OASISExpr.ml" *) - - - - open OASISGettext - - type test = string - - type flag = string - - type t = - | EBool of bool - | ENot of t - | EAnd of t * t - | EOr of t * t - | EFlag of flag - | ETest of test * string - - - type 'a choices = (t * 'a) list - - let eval var_get t = - let rec eval' = - function - | EBool b -> - b - - | ENot e -> - not (eval' e) - - | EAnd (e1, e2) -> - (eval' e1) && (eval' e2) - - | EOr (e1, e2) -> - (eval' e1) || (eval' e2) - - | EFlag nm -> - let v = - var_get nm - in - assert(v = "true" || v = "false"); - (v = "true") - - | ETest (nm, vl) -> - let v = - var_get nm - in - (v = vl) - in - eval' t - - let choose ?printer ?name var_get lst = - let rec choose_aux = - function - | (cond, vl) :: tl -> - if eval var_get cond then - vl - else - choose_aux tl - | [] -> - let str_lst = - if lst = [] then - s_ "" - else - String.concat - (s_ ", ") - (List.map - (fun (cond, vl) -> - match printer with - | Some p -> p vl - | None -> s_ "") - lst) - in - match name with - | Some nm -> - failwith - (Printf.sprintf - (f_ "No result for the choice list '%s': %s") - nm str_lst) - | None -> - failwith - (Printf.sprintf - (f_ "No result for a choice list: %s") - str_lst) - in - choose_aux (List.rev lst) - -end - - -# 117 "myocamlbuild.ml" -module BaseEnvLight = struct -(* # 21 "src/base/BaseEnvLight.ml" *) - - module MapString = Map.Make(String) - - type t = string MapString.t - - let default_filename = - Filename.concat - (Sys.getcwd ()) - "setup.data" - - let load ?(allow_empty=false) ?(filename=default_filename) () = - if Sys.file_exists filename then - begin - let chn = - open_in_bin filename - in - let st = - Stream.of_channel chn - in - let line = - ref 1 - in - let st_line = - Stream.from - (fun _ -> - try - match Stream.next st with - | '\n' -> incr line; Some '\n' - | c -> Some c - with Stream.Failure -> None) - in - let lexer = - Genlex.make_lexer ["="] st_line - in - let rec read_file mp = - match Stream.npeek 3 lexer with - | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> - Stream.junk lexer; - Stream.junk lexer; - Stream.junk lexer; - read_file (MapString.add nm value mp) - | [] -> - mp - | _ -> - failwith - (Printf.sprintf - "Malformed data file '%s' line %d" - filename !line) - in - let mp = - read_file MapString.empty - in - close_in chn; - mp - end - else if allow_empty then - begin - MapString.empty - end - else - begin - failwith - (Printf.sprintf - "Unable to load environment, the file '%s' doesn't exist." - filename) - end - - let var_get name env = - let rec var_expand str = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff - in - var_expand (MapString.find name env) - - let var_choose lst env = - OASISExpr.choose - (fun nm -> var_get nm env) - lst -end - - -# 215 "myocamlbuild.ml" -module MyOCamlbuildFindlib = struct -(* # 21 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) - - (** OCamlbuild extension, copied from - * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild - * by N. Pouillard and others - * - * Updated on 2009/02/28 - * - * Modified by Sylvain Le Gall - *) - open Ocamlbuild_plugin - - (* these functions are not really officially exported *) - let run_and_read = - Ocamlbuild_pack.My_unix.run_and_read - - let blank_sep_strings = - Ocamlbuild_pack.Lexers.blank_sep_strings - - 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 before_space s = - try - String.before s (String.index s ' ') - with Not_found -> s - - (* this lists all supported packages *) - let find_packages () = - List.map before_space (split_nl & run_and_read "ocamlfind list") - - (* this is supposed to list available syntaxes, but I don't know how to do it. *) - let find_syntaxes () = ["camlp4o"; "camlp4r"] - - (* ocamlfind command *) - let ocamlfind x = S[A"ocamlfind"; x] - - let dispatch = - function - | Before_options -> - (* by using Before_options one let command line options have an higher priority *) - (* on the contrary using After_options will guarantee to have the higher priority *) - (* override default commands by ocamlfind ones *) - Options.ocamlc := ocamlfind & A"ocamlc"; - Options.ocamlopt := ocamlfind & A"ocamlopt"; - Options.ocamldep := ocamlfind & A"ocamldep"; - Options.ocamldoc := ocamlfind & A"ocamldoc"; - Options.ocamlmktop := ocamlfind & A"ocamlmktop" - - | After_rules -> - - (* When one link an OCaml library/binary/package, one should use -linkpkg *) - flag ["ocaml"; "link"; "program"] & 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]; - end - (find_packages ()); - - (* Like -package but for extensions syntax. Morover -syntax is useless - * when linking. *) - List.iter begin fun syntax -> - flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - end (find_syntaxes ()); - - (* The default "thread" tag is not compatible with ocamlfind. - * Indeed, the default rules add the "threads.cma" or "threads.cmxa" - * options when using this tag. When using the "-linkpkg" option with - * ocamlfind, this module will then be added twice on the command line. - * - * To solve this, one approach is to add the "-thread" option when using - * the "threads" package using the previous plugin. - *) - flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); - flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); - flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); - flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]) - - | _ -> - () - -end - -module MyOCamlbuildBase = struct -(* # 21 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) - - (** Base functions for writing myocamlbuild.ml - @author Sylvain Le Gall - *) - - - - open Ocamlbuild_plugin - module OC = Ocamlbuild_pack.Ocaml_compiler - - type dir = string - type file = string - type name = string - type tag = string - -(* # 56 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) - - type t = - { - lib_ocaml: (name * dir list) list; - lib_c: (name * dir * file list) list; - flags: (tag list * (spec OASISExpr.choices)) list; - (* Replace the 'dir: include' from _tags by a precise interdepends in - * directory. - *) - includes: (dir * dir list) list; - } - - let env_filename = - Pathname.basename - BaseEnvLight.default_filename - - let dispatch_combine lst = - fun e -> - List.iter - (fun dispatch -> dispatch e) - lst - - let tag_libstubs nm = - "use_lib"^nm^"_stubs" - - let nm_libstubs nm = - nm^"_stubs" - - let dispatch t e = - let env = - BaseEnvLight.load - ~filename:env_filename - ~allow_empty:true - () - in - match e with - | Before_options -> - let no_trailing_dot s = - if String.length s >= 1 && s.[0] = '.' then - String.sub s 1 ((String.length s) - 1) - else - s - in - List.iter - (fun (opt, var) -> - try - opt := no_trailing_dot (BaseEnvLight.var_get var env) - with Not_found -> - Printf.eprintf "W: Cannot get variable %s" var) - [ - Options.ext_obj, "ext_obj"; - Options.ext_lib, "ext_lib"; - Options.ext_dll, "ext_dll"; - ] - - | After_rules -> - (* Declare OCaml libraries *) - List.iter - (function - | nm, [] -> - ocaml_lib nm - | nm, dir :: tl -> - ocaml_lib ~dir:dir (dir^"/"^nm); - List.iter - (fun dir -> - List.iter - (fun str -> - flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) - ["compile"; "infer_interface"; "doc"]) - tl) - t.lib_ocaml; - - (* Declare directories dependencies, replace "include" in _tags. *) - List.iter - (fun (dir, include_dirs) -> - Pathname.define_context dir include_dirs) - t.includes; - - (* Declare C libraries *) - List.iter - (fun (lib, dir, headers) -> - (* Handle C part of library *) - flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] - (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; - A("-l"^(nm_libstubs lib))]); - - flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] - (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); - - flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] - (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); - - (* When ocaml link something that use the C library, then one - need that file to be up to date. - *) - dep ["link"; "ocaml"; "program"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; - - dep ["compile"; "ocaml"; "program"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; - - (* TODO: be more specific about what depends on headers *) - (* Depends on .h files *) - dep ["compile"; "c"] - headers; - - (* Setup search path for lib *) - flag ["link"; "ocaml"; "use_"^lib] - (S[A"-I"; P(dir)]); - ) - t.lib_c; - - (* Add flags *) - List.iter - (fun (tags, cond_specs) -> - let spec = - BaseEnvLight.var_choose cond_specs env - in - flag tags & spec) - t.flags - | _ -> - () - - let dispatch_default t = - dispatch_combine - [ - dispatch t; - MyOCamlbuildFindlib.dispatch; - ] - -end - - -# 476 "myocamlbuild.ml" -open Ocamlbuild_plugin;; -let package_default = - { - MyOCamlbuildBase.lib_ocaml = - [("profiling", ["profiling"]); ("networklibs", ["lib"])]; - lib_c = []; - flags = - [ - (["oasis_library_networklibs_ccopt"; "compile"], - [ - (OASISExpr.EBool true, - S - [ - A "-ccopt"; - A "-Wno-unused-function"; - A "-ccopt"; - A "-g"; - A "-ccopt"; - A "-ggdb" - ]) - ]) - ]; - includes = - [ - ("test", ["lib"; "profiling"]); - ("networkd_db", ["lib"; "profiling"]); - ("networkd", ["lib"; "profiling"]); - ("cli", ["lib"; "profiling"]) - ]; - } - ;; - -let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; - -# 512 "myocamlbuild.ml" -(* OASIS_STOP *) -Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/networkd/jbuild b/networkd/jbuild new file mode 100644 index 000000000..8439d33da --- /dev/null +++ b/networkd/jbuild @@ -0,0 +1,41 @@ +(rule + ((targets (version.ml)) + (deps (../VERSION)) + (action (with-stdout-to ${@} (bash "cat ${<} | sed s/^/\"let version = \"\\\"/ | sed s/$/\\\"/"))) + ) +) + +(rule + ((targets (xcp-networkd.1)) + (deps (networkd.exe)) + (action (with-stdout-to ${@} (run ${<} "--help=groff"))) + ) +) + +(executable + ((name networkd) + (public_name xcp-networkd) + (package xcp-networkd) + (flags (:standard -bin-annot -warn-error +a-33-6-9-27)) + (libraries (networklibs + profiling + threads + rpclib + rpclib.unix + forkexec + stdext + xcp-inventory + xen-api-client + xcp + xcp.network + netlink + systemd) + ) + ) +) + +(alias + ((name man) + (deps (xcp-networkd.1)) + ) +) diff --git a/networkd_db/jbuild b/networkd_db/jbuild new file mode 100644 index 000000000..87afd99f3 --- /dev/null +++ b/networkd_db/jbuild @@ -0,0 +1,13 @@ +(executable + ((name networkd_db) + (public_name networkd_db) + (package xcp-networkd) + (flags (:standard -bin-annot -warn-error +a-27)) + (libraries (profiling + networklibs + stdext + threads + xcp.network) + ) + ) +) \ No newline at end of file diff --git a/opam b/opam deleted file mode 100644 index 7799a1733..000000000 --- a/opam +++ /dev/null @@ -1,17 +0,0 @@ -opam-version: "1" -maintainer: "jonathan.ludlam@eu.citrix.com" -build: [ - [make] - [make "install" "BINDIR=%{bin}%" "SBINDIR=%{bin}%" "LIBEXECDIR=%{bin}%" "SCRIPTSDIR=%{bin}%" "ETCDIR=%{prefix}%/etc"] -] -remove: [make "uninstall" "BINDIR=%{bin}%" "SBINDIR=%{bin}%" "LIBEXECDIR=%{bin}%" "SCRIPTSDIR=%{bin}%" "ETCDIR=%{prefix}%/etc"] -depends: [ - "ocamlfind" - "systemd" - "xapi-idl" - "xapi-libs-transitional" - "xen-api-client" - "xapi-inventory" - "netlink" - "bisect_ppx" -] diff --git a/profiling/META b/profiling/META deleted file mode 100644 index 00e717fc8..000000000 --- a/profiling/META +++ /dev/null @@ -1,11 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 64d9d987fb0efbdbfeb0624623750120) -version = "0.10.0" -description = "XCP Network Daemon" -archive(byte) = "profiling.cma" -archive(byte, plugin) = "profiling.cma" -archive(native) = "profiling.cmxa" -archive(native, plugin) = "profiling.cmxs" -exists_if = "profiling.cma" -# OASIS_STOP - diff --git a/profiling/coverage.mldylib b/profiling/coverage.mldylib deleted file mode 100644 index 2c6e555c2..000000000 --- a/profiling/coverage.mldylib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 9841bdc50c4226cb6ec5db76494249e6) -Coverage -# OASIS_STOP diff --git a/profiling/coverage.mllib b/profiling/coverage.mllib deleted file mode 100644 index 2c6e555c2..000000000 --- a/profiling/coverage.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 9841bdc50c4226cb6ec5db76494249e6) -Coverage -# OASIS_STOP diff --git a/profiling/jbuild b/profiling/jbuild new file mode 100644 index 000000000..76fc54b0a --- /dev/null +++ b/profiling/jbuild @@ -0,0 +1,8 @@ +(jbuild_version 1) + +(library + ((name profiling) + (flags (:standard -bin-annot)) + (wrapped false) + ) +) \ No newline at end of file diff --git a/profiling/profiling.mldylib b/profiling/profiling.mldylib deleted file mode 100644 index 2c6e555c2..000000000 --- a/profiling/profiling.mldylib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 9841bdc50c4226cb6ec5db76494249e6) -Coverage -# OASIS_STOP diff --git a/profiling/profiling.mllib b/profiling/profiling.mllib deleted file mode 100644 index 2c6e555c2..000000000 --- a/profiling/profiling.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 9841bdc50c4226cb6ec5db76494249e6) -Coverage -# OASIS_STOP diff --git a/setup.ml b/setup.ml deleted file mode 100644 index 50bd3a945..000000000 --- a/setup.ml +++ /dev/null @@ -1,6071 +0,0 @@ -(* setup.ml generated for the first time by OASIS v0.4.4 *) - -(* OASIS_START *) -(* DO NOT EDIT (digest: 705e1ead1104847e0c184cf5fad79198) *) -(* - 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 "src/oasis/OASISGettext.ml" *) - - let ns_ str = - str - - let s_ str = - str - - let f_ (str : ('a, 'b, 'c, 'd) format4) = - str - - let fn_ fmt1 fmt2 n = - if n = 1 then - fmt1^^"" - else - fmt2^^"" - - let init = - [] - -end - -module OASISContext = struct -(* # 21 "src/oasis/OASISContext.ml" *) - - open OASISGettext - - type level = - [ `Debug - | `Info - | `Warning - | `Error] - - type t = - { - quiet: bool; - info: bool; - debug: bool; - ignore_plugins: bool; - ignore_unknown_fields: bool; - printf: level -> string -> unit; - } - - let printf lvl str = - let beg = - match lvl with - | `Error -> s_ "E: " - | `Warning -> s_ "W: " - | `Info -> s_ "I: " - | `Debug -> s_ "D: " - in - prerr_endline (beg^str) - - let default = - ref - { - quiet = false; - info = false; - debug = false; - ignore_plugins = false; - ignore_unknown_fields = false; - printf = printf; - } - - let quiet = - {!default with quiet = true} - - - let args () = - ["-quiet", - Arg.Unit (fun () -> default := {!default with quiet = true}), - (s_ " Run quietly"); - - "-info", - Arg.Unit (fun () -> default := {!default with info = true}), - (s_ " Display information message"); - - - "-debug", - Arg.Unit (fun () -> default := {!default with debug = true}), - (s_ " Output debug message")] -end - -module OASISString = struct -(* # 1 "src/oasis/OASISString.ml" *) - - - - (** Various string utilities. - - Mostly inspired by extlib and batteries ExtString and BatString libraries. - - @author Sylvain Le Gall - *) - - let nsplitf str f = - if str = "" then - [] - else - let buf = Buffer.create 13 in - let lst = ref [] in - let push () = - lst := Buffer.contents buf :: !lst; - Buffer.clear buf - in - let str_len = String.length str in - for i = 0 to str_len - 1 do - if f str.[i] then - push () - else - Buffer.add_char buf str.[i] - done; - push (); - List.rev !lst - - (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the - separator. - *) - let nsplit str c = - nsplitf str ((=) c) - - let find ~what ?(offset=0) str = - let what_idx = ref 0 in - let str_idx = ref offset in - while !str_idx < String.length str && - !what_idx < String.length what do - if str.[!str_idx] = what.[!what_idx] then - incr what_idx - else - what_idx := 0; - incr str_idx - done; - if !what_idx <> String.length what then - raise Not_found - else - !str_idx - !what_idx - - let sub_start str len = - let str_len = String.length str in - if len >= str_len then - "" - else - String.sub str len (str_len - len) - - let sub_end ?(offset=0) str len = - let str_len = String.length str in - if len >= str_len then - "" - else - String.sub str 0 (str_len - len) - - let starts_with ~what ?(offset=0) str = - let what_idx = ref 0 in - let str_idx = ref offset in - let ok = ref true in - while !ok && - !str_idx < String.length str && - !what_idx < String.length what do - if str.[!str_idx] = what.[!what_idx] then - incr what_idx - else - ok := false; - incr str_idx - done; - if !what_idx = String.length what then - true - else - false - - let strip_starts_with ~what str = - if starts_with ~what str then - sub_start str (String.length what) - else - raise Not_found - - let ends_with ~what ?(offset=0) str = - let what_idx = ref ((String.length what) - 1) in - let str_idx = ref ((String.length str) - 1) in - let ok = ref true in - while !ok && - offset <= !str_idx && - 0 <= !what_idx do - if str.[!str_idx] = what.[!what_idx] then - decr what_idx - else - ok := false; - decr str_idx - done; - if !what_idx = -1 then - true - else - false - - let strip_ends_with ~what str = - if ends_with ~what str then - sub_end str (String.length what) - else - raise Not_found - - let replace_chars f s = - let buf = String.make (String.length s) 'X' in - for i = 0 to String.length s - 1 do - buf.[i] <- f s.[i] - done; - buf - -end - -module OASISUtils = struct -(* # 21 "src/oasis/OASISUtils.ml" *) - - open OASISGettext - - module MapString = Map.Make(String) - - let map_string_of_assoc assoc = - List.fold_left - (fun acc (k, v) -> MapString.add k v acc) - MapString.empty - assoc - - module SetString = Set.Make(String) - - let set_string_add_list st lst = - List.fold_left - (fun acc e -> SetString.add e acc) - st - lst - - let set_string_of_list = - set_string_add_list - SetString.empty - - - let compare_csl s1 s2 = - String.compare (String.lowercase s1) (String.lowercase s2) - - module HashStringCsl = - Hashtbl.Make - (struct - type t = string - - let equal s1 s2 = - (String.lowercase s1) = (String.lowercase s2) - - let hash s = - Hashtbl.hash (String.lowercase s) - end) - - let varname_of_string ?(hyphen='_') s = - if String.length s = 0 then - begin - invalid_arg "varname_of_string" - end - else - begin - let buf = - OASISString.replace_chars - (fun c -> - if ('a' <= c && c <= 'z') - || - ('A' <= c && c <= 'Z') - || - ('0' <= c && c <= '9') then - c - else - hyphen) - s; - in - let buf = - (* Start with a _ if digit *) - if '0' <= s.[0] && s.[0] <= '9' then - "_"^buf - else - buf - in - String.lowercase buf - end - - let varname_concat ?(hyphen='_') p s = - let what = String.make 1 hyphen in - let p = - try - OASISString.strip_ends_with ~what p - with Not_found -> - p - in - let s = - try - OASISString.strip_starts_with ~what s - with Not_found -> - s - in - p^what^s - - - let is_varname str = - str = varname_of_string str - - let failwithf fmt = Printf.ksprintf failwith fmt - -end - -module PropList = struct -(* # 21 "src/oasis/PropList.ml" *) - - open OASISGettext - - type name = string - - exception Not_set of name * string option - exception No_printer of name - exception Unknown_field of name * name - - let () = - Printexc.register_printer - (function - | Not_set (nm, Some rsn) -> - Some - (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) - | Not_set (nm, None) -> - Some - (Printf.sprintf (f_ "Field '%s' is not set") nm) - | No_printer nm -> - Some - (Printf.sprintf (f_ "No default printer for value %s") nm) - | Unknown_field (nm, schm) -> - Some - (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm) - | _ -> - None) - - module Data = - struct - - type t = - (name, unit -> unit) Hashtbl.t - - let create () = - Hashtbl.create 13 - - let clear t = - Hashtbl.clear t - -(* # 71 "src/oasis/PropList.ml" *) - end - - module Schema = - struct - - type ('ctxt, 'extra) value = - { - get: Data.t -> string; - set: Data.t -> ?context:'ctxt -> string -> unit; - help: (unit -> string) option; - extra: 'extra; - } - - type ('ctxt, 'extra) t = - { - name: name; - fields: (name, ('ctxt, 'extra) value) Hashtbl.t; - order: name Queue.t; - name_norm: string -> string; - } - - let create ?(case_insensitive=false) nm = - { - name = nm; - fields = Hashtbl.create 13; - order = Queue.create (); - name_norm = - (if case_insensitive then - String.lowercase - else - fun s -> s); - } - - let add t nm set get extra help = - let key = - t.name_norm nm - in - - if Hashtbl.mem t.fields key then - failwith - (Printf.sprintf - (f_ "Field '%s' is already defined in schema '%s'") - nm t.name); - Hashtbl.add - t.fields - key - { - set = set; - get = get; - help = help; - extra = extra; - }; - Queue.add nm t.order - - let mem t nm = - Hashtbl.mem t.fields nm - - let find t nm = - try - Hashtbl.find t.fields (t.name_norm nm) - with Not_found -> - raise (Unknown_field (nm, t.name)) - - let get t data nm = - (find t nm).get data - - let set t data nm ?context x = - (find t nm).set - data - ?context - x - - let fold f acc t = - Queue.fold - (fun acc k -> - let v = - find t k - in - f acc k v.extra v.help) - acc - t.order - - let iter f t = - fold - (fun () -> f) - () - t - - let name t = - t.name - end - - module Field = - struct - - type ('ctxt, 'value, 'extra) t = - { - set: Data.t -> ?context:'ctxt -> 'value -> unit; - get: Data.t -> 'value; - sets: Data.t -> ?context:'ctxt -> string -> unit; - gets: Data.t -> string; - help: (unit -> string) option; - extra: 'extra; - } - - let new_id = - let last_id = - ref 0 - in - fun () -> incr last_id; !last_id - - let create ?schema ?name ?parse ?print ?default ?update ?help extra = - (* Default value container *) - let v = - ref None - in - - (* If name is not given, create unique one *) - let nm = - match name with - | Some s -> s - | None -> Printf.sprintf "_anon_%d" (new_id ()) - in - - (* Last chance to get a value: the default *) - let default () = - match default with - | Some d -> d - | None -> raise (Not_set (nm, Some (s_ "no default value"))) - in - - (* Get data *) - let get data = - (* Get value *) - try - (Hashtbl.find data nm) (); - match !v with - | Some x -> x - | None -> default () - with Not_found -> - default () - in - - (* Set data *) - let set data ?context x = - let x = - match update with - | Some f -> - begin - try - f ?context (get data) x - with Not_set _ -> - x - end - | None -> - x - in - Hashtbl.replace - data - nm - (fun () -> v := Some x) - in - - (* Parse string value, if possible *) - let parse = - match parse with - | Some f -> - f - | None -> - fun ?context s -> - failwith - (Printf.sprintf - (f_ "Cannot parse field '%s' when setting value %S") - nm - s) - in - - (* Set data, from string *) - let sets data ?context s = - set ?context data (parse ?context s) - in - - (* Output value as string, if possible *) - let print = - match print with - | Some f -> - f - | None -> - fun _ -> raise (No_printer nm) - in - - (* Get data, as a string *) - let gets data = - print (get data) - in - - begin - match schema with - | Some t -> - Schema.add t nm sets gets extra help - | None -> - () - end; - - { - set = set; - get = get; - sets = sets; - gets = gets; - help = help; - extra = extra; - } - - let fset data t ?context x = - t.set data ?context x - - let fget data t = - t.get data - - let fsets data t ?context s = - t.sets data ?context s - - let fgets data t = - t.gets data - - end - - module FieldRO = - struct - - let create ?schema ?name ?parse ?print ?default ?update ?help extra = - let fld = - Field.create ?schema ?name ?parse ?print ?default ?update ?help extra - in - fun data -> Field.fget data fld - - end -end - -module OASISMessage = struct -(* # 21 "src/oasis/OASISMessage.ml" *) - - - open OASISGettext - open OASISContext - - let generic_message ~ctxt lvl fmt = - let cond = - if ctxt.quiet then - false - else - match lvl with - | `Debug -> ctxt.debug - | `Info -> ctxt.info - | _ -> true - in - Printf.ksprintf - (fun str -> - if cond then - begin - ctxt.printf lvl str - end) - fmt - - let debug ~ctxt fmt = - generic_message ~ctxt `Debug fmt - - let info ~ctxt fmt = - generic_message ~ctxt `Info fmt - - let warning ~ctxt fmt = - generic_message ~ctxt `Warning fmt - - let error ~ctxt fmt = - generic_message ~ctxt `Error fmt - -end - -module OASISVersion = struct -(* # 21 "src/oasis/OASISVersion.ml" *) - - open OASISGettext - - - - type s = string - - type t = string - - type comparator = - | VGreater of t - | VGreaterEqual of t - | VEqual of t - | VLesser of t - | VLesserEqual of t - | VOr of comparator * comparator - | VAnd of comparator * comparator - - - (* Range of allowed characters *) - let is_digit c = - '0' <= c && c <= '9' - - let is_alpha c = - ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') - - let is_special = - function - | '.' | '+' | '-' | '~' -> true - | _ -> false - - let rec version_compare v1 v2 = - if v1 <> "" || v2 <> "" then - begin - (* Compare ascii string, using special meaning for version - * related char - *) - let val_ascii c = - if c = '~' then -1 - else if is_digit c then 0 - else if c = '\000' then 0 - else if is_alpha c then Char.code c - else (Char.code c) + 256 - in - - let len1 = String.length v1 in - let len2 = String.length v2 in - - let p = ref 0 in - - (** Compare ascii part *) - let compare_vascii () = - let cmp = ref 0 in - while !cmp = 0 && - !p < len1 && !p < len2 && - not (is_digit v1.[!p] && is_digit v2.[!p]) do - cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); - incr p - done; - if !cmp = 0 && !p < len1 && !p = len2 then - val_ascii v1.[!p] - else if !cmp = 0 && !p = len1 && !p < len2 then - - (val_ascii v2.[!p]) - else - !cmp - in - - (** Compare digit part *) - let compare_digit () = - let extract_int v p = - let start_p = !p in - while !p < String.length v && is_digit v.[!p] do - incr p - done; - let substr = - String.sub v !p ((String.length v) - !p) - in - let res = - match String.sub v start_p (!p - start_p) with - | "" -> 0 - | s -> int_of_string s - in - res, substr - in - let i1, tl1 = extract_int v1 (ref !p) in - let i2, tl2 = extract_int v2 (ref !p) in - i1 - i2, tl1, tl2 - in - - match compare_vascii () with - | 0 -> - begin - match compare_digit () with - | 0, tl1, tl2 -> - if tl1 <> "" && is_digit tl1.[0] then - 1 - else if tl2 <> "" && is_digit tl2.[0] then - -1 - else - version_compare tl1 tl2 - | n, _, _ -> - n - end - | n -> - n - end - else - begin - 0 - end - - - let version_of_string str = str - - let string_of_version t = t - - let chop t = - try - let pos = - String.rindex t '.' - in - String.sub t 0 pos - with Not_found -> - t - - let rec comparator_apply v op = - match op with - | VGreater cv -> - (version_compare v cv) > 0 - | VGreaterEqual cv -> - (version_compare v cv) >= 0 - | VLesser cv -> - (version_compare v cv) < 0 - | VLesserEqual cv -> - (version_compare v cv) <= 0 - | VEqual cv -> - (version_compare v cv) = 0 - | VOr (op1, op2) -> - (comparator_apply v op1) || (comparator_apply v op2) - | VAnd (op1, op2) -> - (comparator_apply v op1) && (comparator_apply v op2) - - let rec string_of_comparator = - function - | VGreater v -> "> "^(string_of_version v) - | VEqual v -> "= "^(string_of_version v) - | VLesser v -> "< "^(string_of_version v) - | VGreaterEqual v -> ">= "^(string_of_version v) - | VLesserEqual v -> "<= "^(string_of_version v) - | VOr (c1, c2) -> - (string_of_comparator c1)^" || "^(string_of_comparator c2) - | VAnd (c1, c2) -> - (string_of_comparator c1)^" && "^(string_of_comparator c2) - - let rec varname_of_comparator = - let concat p v = - OASISUtils.varname_concat - p - (OASISUtils.varname_of_string - (string_of_version v)) - in - function - | VGreater v -> concat "gt" v - | VLesser v -> concat "lt" v - | VEqual v -> concat "eq" v - | VGreaterEqual v -> concat "ge" v - | VLesserEqual v -> concat "le" v - | VOr (c1, c2) -> - (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) - | VAnd (c1, c2) -> - (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) - - let version_0_3_or_after t = - comparator_apply t (VGreaterEqual (string_of_version "0.3")) - -end - -module OASISLicense = struct -(* # 21 "src/oasis/OASISLicense.ml" *) - - (** License for _oasis fields - @author Sylvain Le Gall - *) - - - - type license = string - - type license_exception = string - - type license_version = - | Version of OASISVersion.t - | VersionOrLater of OASISVersion.t - | NoVersion - - - type license_dep_5_unit = - { - license: license; - excption: license_exception option; - version: license_version; - } - - - type license_dep_5 = - | DEP5Unit of license_dep_5_unit - | DEP5Or of license_dep_5 list - | DEP5And of license_dep_5 list - - - type t = - | DEP5License of license_dep_5 - | OtherLicense of string (* URL *) - - -end - -module OASISExpr = struct -(* # 21 "src/oasis/OASISExpr.ml" *) - - - - open OASISGettext - - type test = string - - type flag = string - - type t = - | EBool of bool - | ENot of t - | EAnd of t * t - | EOr of t * t - | EFlag of flag - | ETest of test * string - - - type 'a choices = (t * 'a) list - - let eval var_get t = - let rec eval' = - function - | EBool b -> - b - - | ENot e -> - not (eval' e) - - | EAnd (e1, e2) -> - (eval' e1) && (eval' e2) - - | EOr (e1, e2) -> - (eval' e1) || (eval' e2) - - | EFlag nm -> - let v = - var_get nm - in - assert(v = "true" || v = "false"); - (v = "true") - - | ETest (nm, vl) -> - let v = - var_get nm - in - (v = vl) - in - eval' t - - let choose ?printer ?name var_get lst = - let rec choose_aux = - function - | (cond, vl) :: tl -> - if eval var_get cond then - vl - else - choose_aux tl - | [] -> - let str_lst = - if lst = [] then - s_ "" - else - String.concat - (s_ ", ") - (List.map - (fun (cond, vl) -> - match printer with - | Some p -> p vl - | None -> s_ "") - lst) - in - match name with - | Some nm -> - failwith - (Printf.sprintf - (f_ "No result for the choice list '%s': %s") - nm str_lst) - | None -> - failwith - (Printf.sprintf - (f_ "No result for a choice list: %s") - str_lst) - in - choose_aux (List.rev lst) - -end - -module OASISTypes = struct -(* # 21 "src/oasis/OASISTypes.ml" *) - - - - - type name = string - type package_name = string - type url = string - type unix_dirname = string - type unix_filename = string - type host_dirname = string - type host_filename = string - type prog = string - type arg = string - type args = string list - type command_line = (prog * arg list) - - type findlib_name = string - type findlib_full = string - - type compiled_object = - | Byte - | Native - | Best - - - type dependency = - | FindlibPackage of findlib_full * OASISVersion.comparator option - | InternalLibrary of name - - - type tool = - | ExternalTool of name - | InternalExecutable of name - - - type vcs = - | Darcs - | Git - | Svn - | Cvs - | Hg - | Bzr - | Arch - | Monotone - | OtherVCS of url - - - type plugin_kind = - [ `Configure - | `Build - | `Doc - | `Test - | `Install - | `Extra - ] - - type plugin_data_purpose = - [ `Configure - | `Build - | `Install - | `Clean - | `Distclean - | `Install - | `Uninstall - | `Test - | `Doc - | `Extra - | `Other of string - ] - - type 'a plugin = 'a * name * OASISVersion.t option - - type all_plugin = plugin_kind plugin - - type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list - -(* # 102 "src/oasis/OASISTypes.ml" *) - - type 'a conditional = 'a OASISExpr.choices - - type custom = - { - pre_command: (command_line option) conditional; - post_command: (command_line option) conditional; - } - - - type common_section = - { - cs_name: name; - cs_data: PropList.Data.t; - cs_plugin_data: plugin_data; - } - - - type build_section = - { - bs_build: bool conditional; - bs_install: bool conditional; - bs_path: unix_dirname; - bs_compiled_object: compiled_object; - bs_build_depends: dependency list; - bs_build_tools: tool list; - bs_c_sources: unix_filename list; - bs_data_files: (unix_filename * unix_filename option) list; - bs_ccopt: args conditional; - bs_cclib: args conditional; - bs_dlllib: args conditional; - bs_dllpath: args conditional; - bs_byteopt: args conditional; - bs_nativeopt: args conditional; - } - - - type library = - { - lib_modules: string list; - lib_pack: bool; - lib_internal_modules: string list; - lib_findlib_parent: findlib_name option; - lib_findlib_name: findlib_name option; - lib_findlib_containers: findlib_name list; - } - - type executable = - { - exec_custom: bool; - exec_main_is: unix_filename; - } - - type flag = - { - flag_description: string option; - flag_default: bool conditional; - } - - type source_repository = - { - src_repo_type: vcs; - src_repo_location: url; - src_repo_browser: url option; - src_repo_module: string option; - src_repo_branch: string option; - src_repo_tag: string option; - src_repo_subdir: unix_filename option; - } - - type test = - { - test_type: [`Test] plugin; - test_command: command_line conditional; - test_custom: custom; - test_working_directory: unix_filename option; - test_run: bool conditional; - test_tools: tool list; - } - - type doc_format = - | HTML of unix_filename - | DocText - | PDF - | PostScript - | Info of unix_filename - | DVI - | OtherDoc - - - type doc = - { - doc_type: [`Doc] plugin; - doc_custom: custom; - doc_build: bool conditional; - doc_install: bool conditional; - doc_install_dir: unix_filename; - doc_title: string; - doc_authors: string list; - doc_abstract: string option; - doc_format: doc_format; - doc_data_files: (unix_filename * unix_filename option) list; - doc_build_tools: tool list; - } - - type section = - | Library of common_section * build_section * library - | Executable of common_section * build_section * executable - | Flag of common_section * flag - | SrcRepo of common_section * source_repository - | Test of common_section * test - | Doc of common_section * doc - - - type section_kind = - [ `Library | `Executable | `Flag | `SrcRepo | `Test | `Doc ] - - type package = - { - oasis_version: OASISVersion.t; - ocaml_version: OASISVersion.comparator option; - findlib_version: OASISVersion.comparator option; - name: package_name; - version: OASISVersion.t; - license: OASISLicense.t; - license_file: unix_filename option; - copyrights: string list; - maintainers: string list; - authors: string list; - homepage: url option; - synopsis: string; - description: string option; - categories: url list; - - conf_type: [`Configure] plugin; - conf_custom: custom; - - build_type: [`Build] plugin; - build_custom: custom; - - install_type: [`Install] plugin; - install_custom: custom; - uninstall_custom: custom; - - clean_custom: custom; - distclean_custom: custom; - - files_ab: unix_filename list; - sections: section list; - plugins: [`Extra] plugin list; - schema_data: PropList.Data.t; - plugin_data: plugin_data; - } - -end - -module OASISUnixPath = struct -(* # 21 "src/oasis/OASISUnixPath.ml" *) - - type unix_filename = string - type unix_dirname = string - - type host_filename = string - type host_dirname = string - - let current_dir_name = "." - - let parent_dir_name = ".." - - let is_current_dir fn = - fn = current_dir_name || fn = "" - - let concat f1 f2 = - if is_current_dir f1 then - f2 - else - let f1' = - try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 - in - f1'^"/"^f2 - - let make = - function - | hd :: tl -> - List.fold_left - (fun f p -> concat f p) - hd - tl - | [] -> - invalid_arg "OASISUnixPath.make" - - let dirname f = - try - String.sub f 0 (String.rindex f '/') - with Not_found -> - current_dir_name - - let basename f = - try - let pos_start = - (String.rindex f '/') + 1 - in - String.sub f pos_start ((String.length f) - pos_start) - with Not_found -> - f - - let chop_extension f = - try - let last_dot = - String.rindex f '.' - in - let sub = - String.sub f 0 last_dot - in - try - let last_slash = - String.rindex f '/' - in - if last_slash < last_dot then - sub - else - f - with Not_found -> - sub - - with Not_found -> - f - - let capitalize_file f = - let dir = dirname f in - let base = basename f in - concat dir (String.capitalize base) - - let uncapitalize_file f = - let dir = dirname f in - let base = basename f in - concat dir (String.uncapitalize base) - -end - -module OASISHostPath = struct -(* # 21 "src/oasis/OASISHostPath.ml" *) - - - open Filename - - module Unix = OASISUnixPath - - let make = - function - | [] -> - invalid_arg "OASISHostPath.make" - | hd :: tl -> - List.fold_left Filename.concat hd tl - - let of_unix ufn = - if Sys.os_type = "Unix" then - ufn - else - make - (List.map - (fun p -> - if p = Unix.current_dir_name then - current_dir_name - else if p = Unix.parent_dir_name then - parent_dir_name - else - p) - (OASISString.nsplit ufn '/')) - - -end - -module OASISSection = struct -(* # 21 "src/oasis/OASISSection.ml" *) - - open OASISTypes - - let section_kind_common = - function - | Library (cs, _, _) -> - `Library, cs - | Executable (cs, _, _) -> - `Executable, cs - | Flag (cs, _) -> - `Flag, cs - | SrcRepo (cs, _) -> - `SrcRepo, cs - | Test (cs, _) -> - `Test, cs - | Doc (cs, _) -> - `Doc, cs - - let section_common sct = - snd (section_kind_common sct) - - let section_common_set cs = - function - | Library (_, bs, lib) -> Library (cs, bs, lib) - | Executable (_, bs, exec) -> Executable (cs, bs, exec) - | Flag (_, flg) -> Flag (cs, flg) - | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) - | Test (_, tst) -> Test (cs, tst) - | Doc (_, doc) -> Doc (cs, doc) - - (** Key used to identify section - *) - let section_id sct = - let k, cs = - section_kind_common sct - in - k, cs.cs_name - - let string_of_section sct = - let k, nm = - section_id sct - in - (match k with - | `Library -> "library" - | `Executable -> "executable" - | `Flag -> "flag" - | `SrcRepo -> "src repository" - | `Test -> "test" - | `Doc -> "doc") - ^" "^nm - - let section_find id scts = - List.find - (fun sct -> id = section_id sct) - scts - - module CSection = - struct - type t = section - - let id = section_id - - let compare t1 t2 = - compare (id t1) (id t2) - - let equal t1 t2 = - (id t1) = (id t2) - - let hash t = - Hashtbl.hash (id t) - end - - module MapSection = Map.Make(CSection) - module SetSection = Set.Make(CSection) - -end - -module OASISBuildSection = struct -(* # 21 "src/oasis/OASISBuildSection.ml" *) - -end - -module OASISExecutable = struct -(* # 21 "src/oasis/OASISExecutable.ml" *) - - open OASISTypes - - let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = - let dir = - OASISUnixPath.concat - bs.bs_path - (OASISUnixPath.dirname exec.exec_main_is) - in - let is_native_exec = - match bs.bs_compiled_object with - | Native -> true - | Best -> is_native () - | Byte -> false - in - - OASISUnixPath.concat - dir - (cs.cs_name^(suffix_program ())), - - if not is_native_exec && - not exec.exec_custom && - bs.bs_c_sources <> [] then - Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) - else - None - -end - -module OASISLibrary = struct -(* # 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 (cs, bs, lib) modul = - let possible_base_fn = - List.map - (OASISUnixPath.concat bs.bs_path) - [modul; - OASISUnixPath.uncapitalize_file modul; - OASISUnixPath.capitalize_file modul] - in - (* TODO: we should be able to be able to determine the source for every - * files. Hence we should introduce a Module(source: fn) for the fields - * Modules and InternalModules - *) - List.fold_left - (fun acc base_fn -> - match acc with - | `No_sources _ -> - begin - let file_found = - List.fold_left - (fun acc ext -> - if source_file_exists (base_fn^ext) then - (base_fn^ext) :: acc - else - acc) - [] - [".ml"; ".mli"; ".mll"; ".mly"] - in - match file_found with - | [] -> - acc - | lst -> - `Sources (base_fn, lst) - end - | `Sources _ -> - acc) - (`No_sources possible_base_fn) - possible_base_fn - - 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 - | `Sources (base_fn, lst) -> - (base_fn, lst) :: acc - | `No_sources _ -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in library %s") - modul cs.cs_name; - acc) - [] - (lib.lib_modules @ lib.lib_internal_modules) - - let generated_unix_files - ~ctxt - ~is_native - ~has_native_dynlink - ~ext_lib - ~ext_dll - ~source_file_exists - (cs, bs, lib) = - - let find_modules lst ext = - let find_module modul = - match find_module source_file_exists (cs, bs, lib) modul with - | `Sources (base_fn, _) -> - [base_fn] - | `No_sources lst -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in library %s") - modul cs.cs_name; - lst - in - List.map - (fun nm -> - List.map - (fun base_fn -> base_fn ^"."^ext) - (find_module nm)) - lst - in - - (* The headers that should be compiled along *) - let headers = - if lib.lib_pack then - [] - else - find_modules - lib.lib_modules - "cmi" - in - - (* The .cmx that be compiled along *) - let cmxs = - let should_be_built = - (not lib.lib_pack) && (* Do not install .cmx packed submodules *) - match bs.bs_compiled_object with - | Native -> true - | Best -> is_native - | Byte -> false - in - if should_be_built then - find_modules - (lib.lib_modules @ lib.lib_internal_modules) - "cmx" - else - [] - in - - let acc_nopath = - [] - in - - (* Compute what libraries should be built *) - let acc_nopath = - (* Add the packed header file if required *) - let add_pack_header acc = - if lib.lib_pack then - [cs.cs_name^".cmi"] :: acc - else - acc - in - let byte acc = - add_pack_header ([cs.cs_name^".cma"] :: acc) - in - let native acc = - let acc = - add_pack_header - (if has_native_dynlink then - [cs.cs_name^".cmxs"] :: acc - else acc) - in - [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc - in - match bs.bs_compiled_object with - | Native -> - byte (native acc_nopath) - | Best when is_native -> - byte (native acc_nopath) - | Byte | Best -> - byte acc_nopath - in - - (* Add C library to be built *) - let acc_nopath = - if bs.bs_c_sources <> [] then - begin - ["lib"^cs.cs_name^"_stubs"^ext_lib] - :: - ["dll"^cs.cs_name^"_stubs"^ext_dll] - :: - acc_nopath - end - else - acc_nopath - in - - (* All the files generated *) - List.rev_append - (List.rev_map - (List.rev_map - (OASISUnixPath.concat bs.bs_path)) - acc_nopath) - (headers @ cmxs) - - type data = common_section * build_section * library - type tree = - | Node of (data option) * (tree MapString.t) - | Leaf of data - - let findlib_mapping pkg = - (* Map from library name to either full findlib name or parts + parent. *) - let fndlb_parts_of_lib_name = - let fndlb_parts cs lib = - let name = - match lib.lib_findlib_name with - | Some nm -> nm - | None -> cs.cs_name - in - let name = - String.concat "." (lib.lib_findlib_containers @ [name]) - in - name - in - List.fold_left - (fun mp -> - function - | Library (cs, _, lib) -> - begin - let lib_name = cs.cs_name in - let fndlb_parts = fndlb_parts cs lib in - if MapString.mem lib_name mp then - failwithf - (f_ "The library name '%s' is used more than once.") - lib_name; - match lib.lib_findlib_parent with - | Some lib_name_parent -> - MapString.add - lib_name - (`Unsolved (lib_name_parent, fndlb_parts)) - mp - | None -> - MapString.add - lib_name - (`Solved fndlb_parts) - mp - end - - | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> - mp) - MapString.empty - pkg.sections - in - - (* Solve the above graph to be only library name to full findlib name. *) - let fndlb_name_of_lib_name = - let rec solve visited mp lib_name lib_name_child = - if SetString.mem lib_name visited then - failwithf - (f_ "Library '%s' is involved in a cycle \ - with regard to findlib naming.") - lib_name; - let visited = SetString.add lib_name visited in - try - match MapString.find lib_name mp with - | `Solved fndlb_nm -> - fndlb_nm, mp - | `Unsolved (lib_nm_parent, post_fndlb_nm) -> - let pre_fndlb_nm, mp = - solve visited mp lib_nm_parent lib_name - in - let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in - fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp - with Not_found -> - failwithf - (f_ "Library '%s', which is defined as the findlib parent of \ - library '%s', doesn't exist.") - lib_name lib_name_child - in - let mp = - MapString.fold - (fun lib_name status mp -> - match status with - | `Solved _ -> - (* Solved initialy, no need to go further *) - mp - | `Unsolved _ -> - let _, mp = solve SetString.empty mp lib_name "" in - mp) - fndlb_parts_of_lib_name - fndlb_parts_of_lib_name - in - MapString.map - (function - | `Solved fndlb_nm -> fndlb_nm - | `Unsolved _ -> assert false) - mp - in - - (* Convert an internal library name to a findlib name. *) - let findlib_name_of_library_name lib_nm = - try - MapString.find lib_nm fndlb_name_of_lib_name - with Not_found -> - raise (InternalLibraryNotFound lib_nm) - in - - (* Add a library to the tree. - *) - let add sct mp = - let fndlb_fullname = - let cs, _, _ = sct in - let lib_name = cs.cs_name in - findlib_name_of_library_name lib_name - in - let rec add_children nm_lst (children : tree MapString.t) = - match nm_lst with - | (hd :: tl) -> - begin - let node = - try - add_node tl (MapString.find hd children) - with Not_found -> - (* New node *) - new_node tl - in - MapString.add hd node children - end - | [] -> - (* Should not have a nameless library. *) - assert false - and add_node tl node = - if tl = [] then - begin - match node with - | Node (None, children) -> - Node (Some sct, children) - | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> - (* TODO: allow to merge Package, i.e. - * archive(byte) = "foo.cma foo_init.cmo" - *) - let cs, _, _ = sct in - failwithf - (f_ "Library '%s' and '%s' have the same findlib name '%s'") - cs.cs_name cs'.cs_name fndlb_fullname - end - else - begin - match node with - | Leaf data -> - Node (Some data, add_children tl MapString.empty) - | Node (data_opt, children) -> - Node (data_opt, add_children tl children) - end - and new_node = - function - | [] -> - Leaf sct - | hd :: tl -> - Node (None, MapString.add hd (new_node tl) MapString.empty) - in - add_children (OASISString.nsplit fndlb_fullname '.') mp - in - - let rec group_of_tree mp = - MapString.fold - (fun nm node acc -> - let cur = - match node with - | Node (Some (cs, bs, lib), children) -> - Package (nm, cs, bs, lib, group_of_tree children) - | Node (None, children) -> - Container (nm, group_of_tree children) - | Leaf (cs, bs, lib) -> - Package (nm, cs, bs, lib, []) - in - cur :: acc) - mp [] - in - - let group_mp = - List.fold_left - (fun mp -> - function - | Library (cs, bs, lib) -> - add (cs, bs, lib) mp - | _ -> - mp) - MapString.empty - pkg.sections - in - - let groups = - group_of_tree group_mp - in - - let library_name_of_findlib_name = - Lazy.lazy_from_fun - (fun () -> - (* Revert findlib_name_of_library_name. *) - MapString.fold - (fun k v mp -> MapString.add v k mp) - fndlb_name_of_lib_name - MapString.empty) - in - let library_name_of_findlib_name fndlb_nm = - try - MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) - with Not_found -> - raise (FindlibPackageNotFound fndlb_nm) - in - - groups, - findlib_name_of_library_name, - library_name_of_findlib_name - - let findlib_of_group = - function - | Container (fndlb_nm, _) - | Package (fndlb_nm, _, _, _, _) -> fndlb_nm - - let root_of_group grp = - let rec root_lib_aux = - (* We do a DFS in the group. *) - function - | Container (_, children) -> - List.fold_left - (fun res grp -> - if res = None then - root_lib_aux grp - else - res) - None - children - | Package (_, cs, bs, lib, _) -> - Some (cs, bs, lib) - in - match root_lib_aux grp with - | Some res -> - res - | None -> - failwithf - (f_ "Unable to determine root library of findlib library '%s'") - (findlib_of_group grp) - -end - -module OASISFlag = struct -(* # 21 "src/oasis/OASISFlag.ml" *) - -end - -module OASISPackage = struct -(* # 21 "src/oasis/OASISPackage.ml" *) - -end - -module OASISSourceRepository = struct -(* # 21 "src/oasis/OASISSourceRepository.ml" *) - -end - -module OASISTest = struct -(* # 21 "src/oasis/OASISTest.ml" *) - -end - -module OASISDocument = struct -(* # 21 "src/oasis/OASISDocument.ml" *) - -end - -module OASISExec = struct -(* # 21 "src/oasis/OASISExec.ml" *) - - open OASISGettext - open OASISUtils - open OASISMessage - - (* TODO: I don't like this quote, it is there because $(rm) foo expands to - * 'rm -f' foo... - *) - let run ~ctxt ?f_exit_code ?(quote=true) cmd args = - let cmd = - if quote then - if Sys.os_type = "Win32" then - if String.contains cmd ' ' then - (* Double the 1st double quote... win32... sigh *) - "\""^(Filename.quote cmd) - else - cmd - else - Filename.quote cmd - else - cmd - in - let cmdline = - String.concat " " (cmd :: args) - in - info ~ctxt (f_ "Running command '%s'") cmdline; - match f_exit_code, Sys.command cmdline with - | None, 0 -> () - | None, i -> - failwithf - (f_ "Command '%s' terminated with error code %d") - cmdline i - | Some f, i -> - f i - - let run_read_output ~ctxt ?f_exit_code cmd args = - let fn = - Filename.temp_file "oasis-" ".txt" - in - try - begin - let () = - run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) - in - let chn = - open_in fn - in - let routput = - ref [] - in - begin - try - while true do - routput := (input_line chn) :: !routput - done - with End_of_file -> - () - end; - close_in chn; - Sys.remove fn; - List.rev !routput - end - with e -> - (try Sys.remove fn with _ -> ()); - raise e - - let run_read_one_line ~ctxt ?f_exit_code cmd args = - match run_read_output ~ctxt ?f_exit_code cmd args with - | [fst] -> - fst - | lst -> - failwithf - (f_ "Command return unexpected output %S") - (String.concat "\n" lst) -end - -module OASISFileUtil = struct -(* # 21 "src/oasis/OASISFileUtil.ml" *) - - open OASISGettext - - let file_exists_case fn = - let dirname = Filename.dirname fn in - let basename = Filename.basename fn in - if Sys.file_exists dirname then - if basename = Filename.current_dir_name then - true - else - List.mem - basename - (Array.to_list (Sys.readdir dirname)) - else - false - - let find_file ?(case_sensitive=true) paths exts = - - (* Cardinal product of two list *) - let ( * ) lst1 lst2 = - List.flatten - (List.map - (fun a -> - List.map - (fun b -> a,b) - lst2) - lst1) - in - - let rec combined_paths lst = - match lst with - | p1 :: p2 :: tl -> - let acc = - (List.map - (fun (a,b) -> Filename.concat a b) - (p1 * p2)) - in - combined_paths (acc :: tl) - | [e] -> - e - | [] -> - [] - in - - let alternatives = - List.map - (fun (p,e) -> - if String.length e > 0 && e.[0] <> '.' then - p ^ "." ^ e - else - p ^ e) - ((combined_paths paths) * exts) - in - List.find - (if case_sensitive then - file_exists_case - else - Sys.file_exists) - alternatives - - let which ~ctxt prg = - let path_sep = - match Sys.os_type with - | "Win32" -> - ';' - | _ -> - ':' - in - let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in - let exec_ext = - match Sys.os_type with - | "Win32" -> - "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) - | _ -> - [""] - in - find_file ~case_sensitive:false [path_lst; [prg]] exec_ext - - (**/**) - let rec fix_dir dn = - (* Windows hack because Sys.file_exists "src\\" = false when - * Sys.file_exists "src" = true - *) - let ln = - String.length dn - in - if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then - fix_dir (String.sub dn 0 (ln - 1)) - else - dn - - let q = Filename.quote - (**/**) - - let cp ~ctxt ?(recurse=false) src tgt = - if recurse then - match Sys.os_type with - | "Win32" -> - OASISExec.run ~ctxt - "xcopy" [q src; q tgt; "/E"] - | _ -> - OASISExec.run ~ctxt - "cp" ["-r"; q src; q tgt] - else - OASISExec.run ~ctxt - (match Sys.os_type with - | "Win32" -> "copy" - | _ -> "cp") - [q src; q tgt] - - let mkdir ~ctxt tgt = - OASISExec.run ~ctxt - (match Sys.os_type with - | "Win32" -> "md" - | _ -> "mkdir") - [q tgt] - - let rec mkdir_parent ~ctxt f tgt = - let tgt = - fix_dir tgt - in - if Sys.file_exists tgt then - begin - if not (Sys.is_directory tgt) then - OASISUtils.failwithf - (f_ "Cannot create directory '%s', a file of the same name already \ - exists") - tgt - end - else - begin - mkdir_parent ~ctxt f (Filename.dirname tgt); - if not (Sys.file_exists tgt) then - begin - f tgt; - mkdir ~ctxt tgt - end - end - - let rmdir ~ctxt tgt = - if Sys.readdir tgt = [||] then - begin - match Sys.os_type with - | "Win32" -> - OASISExec.run ~ctxt "rd" [q tgt] - | _ -> - OASISExec.run ~ctxt "rm" ["-r"; q tgt] - end - - let glob ~ctxt fn = - let basename = - Filename.basename fn - in - if String.length basename >= 2 && - basename.[0] = '*' && - basename.[1] = '.' then - begin - let ext_len = - (String.length basename) - 2 - in - let ext = - String.sub basename 2 ext_len - in - let dirname = - Filename.dirname fn - in - Array.fold_left - (fun acc fn -> - try - let fn_ext = - String.sub - fn - ((String.length fn) - ext_len) - ext_len - in - if fn_ext = ext then - (Filename.concat dirname fn) :: acc - else - acc - with Invalid_argument _ -> - acc) - [] - (Sys.readdir dirname) - end - else - begin - if file_exists_case fn then - [fn] - else - [] - end -end - - -# 2142 "setup.ml" -module BaseEnvLight = struct -(* # 21 "src/base/BaseEnvLight.ml" *) - - module MapString = Map.Make(String) - - type t = string MapString.t - - let default_filename = - Filename.concat - (Sys.getcwd ()) - "setup.data" - - let load ?(allow_empty=false) ?(filename=default_filename) () = - if Sys.file_exists filename then - begin - let chn = - open_in_bin filename - in - let st = - Stream.of_channel chn - in - let line = - ref 1 - in - let st_line = - Stream.from - (fun _ -> - try - match Stream.next st with - | '\n' -> incr line; Some '\n' - | c -> Some c - with Stream.Failure -> None) - in - let lexer = - Genlex.make_lexer ["="] st_line - in - let rec read_file mp = - match Stream.npeek 3 lexer with - | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> - Stream.junk lexer; - Stream.junk lexer; - Stream.junk lexer; - read_file (MapString.add nm value mp) - | [] -> - mp - | _ -> - failwith - (Printf.sprintf - "Malformed data file '%s' line %d" - filename !line) - in - let mp = - read_file MapString.empty - in - close_in chn; - mp - end - else if allow_empty then - begin - MapString.empty - end - else - begin - failwith - (Printf.sprintf - "Unable to load environment, the file '%s' doesn't exist." - filename) - end - - let var_get name env = - let rec var_expand str = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff - in - var_expand (MapString.find name env) - - let var_choose lst env = - OASISExpr.choose - (fun nm -> var_get nm env) - lst -end - - -# 2240 "setup.ml" -module BaseContext = struct -(* # 21 "src/base/BaseContext.ml" *) - - open OASISContext - - let args = args - - let default = default - -end - -module BaseMessage = struct -(* # 21 "src/base/BaseMessage.ml" *) - - (** Message to user, overrid for Base - @author Sylvain Le Gall - *) - open OASISMessage - open BaseContext - - let debug fmt = debug ~ctxt:!default fmt - - let info fmt = info ~ctxt:!default fmt - - let warning fmt = warning ~ctxt:!default fmt - - let error fmt = error ~ctxt:!default fmt - -end - -module BaseEnv = struct -(* # 21 "src/base/BaseEnv.ml" *) - - open OASISGettext - open OASISUtils - open PropList - - module MapString = BaseEnvLight.MapString - - type origin_t = - | ODefault - | OGetEnv - | OFileLoad - | OCommandLine - - type cli_handle_t = - | CLINone - | CLIAuto - | CLIWith - | CLIEnable - | CLIUser of (Arg.key * Arg.spec * Arg.doc) list - - type definition_t = - { - hide: bool; - dump: bool; - cli: cli_handle_t; - arg_help: string option; - group: string option; - } - - let schema = - Schema.create "environment" - - (* Environment data *) - let env = - Data.create () - - (* Environment data from file *) - let env_from_file = - ref MapString.empty - - (* Lexer for var *) - let var_lxr = - Genlex.make_lexer [] - - let rec var_expand str = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - (* TODO: this is a quick hack to allow calling Test.Command - * without defining executable name really. I.e. if there is - * an exec Executable toto, then $(toto) should be replace - * by its real name. It is however useful to have this function - * for other variable that depend on the host and should be - * written better than that. - *) - let st = - var_lxr (Stream.of_string var) - in - match Stream.npeek 3 st with - | [Genlex.Ident "utoh"; Genlex.Ident nm] -> - OASISHostPath.of_unix (var_get nm) - | [Genlex.Ident "utoh"; Genlex.String s] -> - OASISHostPath.of_unix s - | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> - String.escaped (var_get nm) - | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> - String.escaped s - | [Genlex.Ident nm] -> - var_get nm - | _ -> - failwithf - (f_ "Unknown expression '%s' in variable expansion of %s.") - var - str - with - | Unknown_field (_, _) -> - failwithf - (f_ "No variable %s defined when trying to expand %S.") - var - str - | Stream.Error e -> - failwithf - (f_ "Syntax error when parsing '%s' when trying to \ - expand %S: %s") - var - str - e) - str; - Buffer.contents buff - - and var_get name = - let vl = - try - Schema.get schema env name - with Unknown_field _ as e -> - begin - try - MapString.find name !env_from_file - with Not_found -> - raise e - end - in - var_expand vl - - let var_choose ?printer ?name lst = - OASISExpr.choose - ?printer - ?name - var_get - lst - - let var_protect vl = - let buff = - Buffer.create (String.length vl) - in - String.iter - (function - | '$' -> Buffer.add_string buff "\\$" - | c -> Buffer.add_char buff c) - vl; - Buffer.contents buff - - let var_define - ?(hide=false) - ?(dump=true) - ?short_desc - ?(cli=CLINone) - ?arg_help - ?group - name (* TODO: type constraint on the fact that name must be a valid OCaml - id *) - dflt = - - let default = - [ - OFileLoad, (fun () -> MapString.find name !env_from_file); - ODefault, dflt; - OGetEnv, (fun () -> Sys.getenv name); - ] - in - - let extra = - { - hide = hide; - dump = dump; - cli = cli; - arg_help = arg_help; - group = group; - } - in - - (* Try to find a value that can be defined - *) - let var_get_low lst = - let errors, res = - List.fold_left - (fun (errors, res) (o, v) -> - if res = None then - begin - try - errors, Some (v ()) - with - | Not_found -> - errors, res - | Failure rsn -> - (rsn :: errors), res - | e -> - (Printexc.to_string e) :: errors, res - end - else - errors, res) - ([], None) - (List.sort - (fun (o1, _) (o2, _) -> - Pervasives.compare o2 o1) - lst) - in - match res, errors with - | Some v, _ -> - v - | None, [] -> - raise (Not_set (name, None)) - | None, lst -> - raise (Not_set (name, Some (String.concat (s_ ", ") lst))) - in - - let help = - match short_desc with - | Some fs -> Some fs - | None -> None - in - - let var_get_lst = - FieldRO.create - ~schema - ~name - ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) - ~print:var_get_low - ~default - ~update:(fun ?context x old_x -> x @ old_x) - ?help - extra - in - - fun () -> - var_expand (var_get_low (var_get_lst env)) - - let var_redefine - ?hide - ?dump - ?short_desc - ?cli - ?arg_help - ?group - name - dflt = - if Schema.mem schema name then - begin - (* TODO: look suspsicious, we want to memorize dflt not dflt () *) - Schema.set schema env ~context:ODefault name (dflt ()); - fun () -> var_get name - end - else - begin - var_define - ?hide - ?dump - ?short_desc - ?cli - ?arg_help - ?group - name - dflt - end - - let var_ignore (e : unit -> string) = - () - - let print_hidden = - var_define - ~hide:true - ~dump:false - ~cli:CLIAuto - ~arg_help:"Print even non-printable variable. (debug)" - "print_hidden" - (fun () -> "false") - - let var_all () = - List.rev - (Schema.fold - (fun acc nm def _ -> - if not def.hide || bool_of_string (print_hidden ()) then - nm :: acc - else - acc) - [] - schema) - - let default_filename = - BaseEnvLight.default_filename - - let load ?allow_empty ?filename () = - env_from_file := BaseEnvLight.load ?allow_empty ?filename () - - let unload () = - env_from_file := MapString.empty; - Data.clear env - - let dump ?(filename=default_filename) () = - let chn = - open_out_bin filename - in - let output nm value = - Printf.fprintf chn "%s=%S\n" nm value - in - let mp_todo = - (* Dump data from schema *) - Schema.fold - (fun mp_todo nm def _ -> - if def.dump then - begin - try - let value = - Schema.get - schema - env - nm - in - output nm value - with Not_set _ -> - () - end; - MapString.remove nm mp_todo) - !env_from_file - schema - in - (* Dump data defined outside of schema *) - MapString.iter output mp_todo; - - (* End of the dump *) - close_out chn - - let print () = - let printable_vars = - Schema.fold - (fun acc nm def short_descr_opt -> - if not def.hide || bool_of_string (print_hidden ()) then - begin - try - let value = - Schema.get - schema - env - nm - in - let txt = - match short_descr_opt with - | Some s -> s () - | None -> nm - in - (txt, value) :: acc - with Not_set _ -> - acc - end - else - acc) - [] - schema - in - let max_length = - List.fold_left max 0 - (List.rev_map String.length - (List.rev_map fst printable_vars)) - in - let dot_pad str = - String.make ((max_length - (String.length str)) + 3) '.' - in - - Printf.printf "\nConfiguration: \n"; - List.iter - (fun (name,value) -> - Printf.printf "%s: %s %s\n" name (dot_pad name) value) - (List.rev printable_vars); - Printf.printf "\n%!" - - let args () = - let arg_concat = - OASISUtils.varname_concat ~hyphen:'-' - in - [ - "--override", - Arg.Tuple - ( - let rvr = ref "" - in - let rvl = ref "" - in - [ - Arg.Set_string rvr; - Arg.Set_string rvl; - Arg.Unit - (fun () -> - Schema.set - schema - env - ~context:OCommandLine - !rvr - !rvl) - ] - ), - "var+val Override any configuration variable."; - - ] - @ - List.flatten - (Schema.fold - (fun acc name def short_descr_opt -> - let var_set s = - Schema.set - schema - env - ~context:OCommandLine - name - s - in - - let arg_name = - OASISUtils.varname_of_string ~hyphen:'-' name - in - - let hlp = - match short_descr_opt with - | Some txt -> txt () - | None -> "" - in - - let arg_hlp = - match def.arg_help with - | Some s -> s - | None -> "str" - in - - let default_value = - try - Printf.sprintf - (f_ " [%s]") - (Schema.get - schema - env - name) - with Not_set _ -> - "" - in - - let args = - match def.cli with - | CLINone -> - [] - | CLIAuto -> - [ - arg_concat "--" arg_name, - Arg.String var_set, - Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value - ] - | CLIWith -> - [ - arg_concat "--with-" arg_name, - Arg.String var_set, - Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value - ] - | CLIEnable -> - let dflt = - if default_value = " [true]" then - s_ " [default: enabled]" - else - s_ " [default: disabled]" - in - [ - arg_concat "--enable-" arg_name, - Arg.Unit (fun () -> var_set "true"), - Printf.sprintf (f_ " %s%s") hlp dflt; - - arg_concat "--disable-" arg_name, - Arg.Unit (fun () -> var_set "false"), - Printf.sprintf (f_ " %s%s") hlp dflt - ] - | CLIUser lst -> - lst - in - args :: acc) - [] - schema) -end - -module BaseArgExt = struct -(* # 21 "src/base/BaseArgExt.ml" *) - - open OASISUtils - open OASISGettext - - let parse argv args = - (* Simulate command line for Arg *) - let current = - ref 0 - in - - try - Arg.parse_argv - ~current:current - (Array.concat [[|"none"|]; argv]) - (Arg.align args) - (failwithf (f_ "Don't know what to do with arguments: '%s'")) - (s_ "configure options:") - with - | Arg.Help txt -> - print_endline txt; - exit 0 - | Arg.Bad txt -> - prerr_endline txt; - exit 1 -end - -module BaseCheck = struct -(* # 21 "src/base/BaseCheck.ml" *) - - open BaseEnv - open BaseMessage - open OASISUtils - open OASISGettext - - let prog_best prg prg_lst = - var_redefine - prg - (fun () -> - let alternate = - List.fold_left - (fun res e -> - match res with - | Some _ -> - res - | None -> - try - Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) - with Not_found -> - None) - None - prg_lst - in - match alternate with - | Some prg -> prg - | None -> raise Not_found) - - let prog prg = - prog_best prg [prg] - - let prog_opt prg = - prog_best prg [prg^".opt"; prg] - - let ocamlfind = - prog "ocamlfind" - - let version - var_prefix - cmp - fversion - () = - (* Really compare version provided *) - let var = - var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) - in - var_redefine - ~hide:true - var - (fun () -> - let version_str = - match fversion () with - | "[Distributed with OCaml]" -> - begin - try - (var_get "ocaml_version") - with Not_found -> - warning - (f_ "Variable ocaml_version not defined, fallback \ - to default"); - Sys.ocaml_version - end - | res -> - res - in - let version = - OASISVersion.version_of_string version_str - in - if OASISVersion.comparator_apply version cmp then - version_str - else - failwithf - (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") - var_prefix - (OASISVersion.string_of_comparator cmp) - version_str) - () - - let package_version pkg = - OASISExec.run_read_one_line ~ctxt:!BaseContext.default - (ocamlfind ()) - ["query"; "-format"; "%v"; pkg] - - let package ?version_comparator pkg () = - let var = - OASISUtils.varname_concat - "pkg_" - (OASISUtils.varname_of_string pkg) - in - let findlib_dir pkg = - let dir = - OASISExec.run_read_one_line ~ctxt:!BaseContext.default - (ocamlfind ()) - ["query"; "-format"; "%d"; pkg] - in - if Sys.file_exists dir && Sys.is_directory dir then - dir - else - failwithf - (f_ "When looking for findlib package %s, \ - directory %s return doesn't exist") - pkg dir - in - let vl = - var_redefine - var - (fun () -> findlib_dir pkg) - () - in - ( - match version_comparator with - | Some ver_cmp -> - ignore - (version - var - ver_cmp - (fun _ -> package_version pkg) - ()) - | None -> - () - ); - vl -end - -module BaseOCamlcConfig = struct -(* # 21 "src/base/BaseOCamlcConfig.ml" *) - - - open BaseEnv - open OASISUtils - open OASISGettext - - module SMap = Map.Make(String) - - let ocamlc = - BaseCheck.prog_opt "ocamlc" - - let ocamlc_config_map = - (* Map name to value for ocamlc -config output - (name ^": "^value) - *) - let rec split_field mp lst = - match lst with - | line :: tl -> - let mp = - try - let pos_semicolon = - String.index line ':' - in - if pos_semicolon > 1 then - ( - let name = - String.sub line 0 pos_semicolon - in - let linelen = - String.length line - in - let value = - if linelen > pos_semicolon + 2 then - String.sub - line - (pos_semicolon + 2) - (linelen - pos_semicolon - 2) - else - "" - in - SMap.add name value mp - ) - else - ( - mp - ) - with Not_found -> - ( - mp - ) - in - split_field mp tl - | [] -> - mp - in - - let cache = - lazy - (var_protect - (Marshal.to_string - (split_field - SMap.empty - (OASISExec.run_read_output - ~ctxt:!BaseContext.default - (ocamlc ()) ["-config"])) - [])) - in - var_redefine - "ocamlc_config_map" - ~hide:true - ~dump:false - (fun () -> - (* TODO: update if ocamlc change !!! *) - Lazy.force cache) - - let var_define nm = - (* Extract data from ocamlc -config *) - let avlbl_config_get () = - Marshal.from_string - (ocamlc_config_map ()) - 0 - in - let chop_version_suffix s = - try - String.sub s 0 (String.index s '+') - with _ -> - s - in - - let nm_config, value_config = - match nm with - | "ocaml_version" -> - "version", chop_version_suffix - | _ -> nm, (fun x -> x) - in - var_redefine - nm - (fun () -> - try - let map = - avlbl_config_get () - in - let value = - SMap.find nm_config map - in - value_config value - with Not_found -> - failwithf - (f_ "Cannot find field '%s' in '%s -config' output") - nm - (ocamlc ())) - -end - -module BaseStandardVar = struct -(* # 21 "src/base/BaseStandardVar.ml" *) - - - open OASISGettext - open OASISTypes - open OASISExpr - open BaseCheck - open BaseEnv - - let ocamlfind = BaseCheck.ocamlfind - let ocamlc = BaseOCamlcConfig.ocamlc - let ocamlopt = prog_opt "ocamlopt" - let ocamlbuild = prog "ocamlbuild" - - - (**/**) - let rpkg = - ref None - - let pkg_get () = - match !rpkg with - | Some pkg -> pkg - | None -> failwith (s_ "OASIS Package is not set") - - let var_cond = ref [] - - let var_define_cond ~since_version f dflt = - let holder = ref (fun () -> dflt) in - let since_version = - OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) - in - var_cond := - (fun ver -> - if OASISVersion.comparator_apply ver since_version then - holder := f ()) :: !var_cond; - fun () -> !holder () - - (**/**) - - let pkg_name = - var_define - ~short_desc:(fun () -> s_ "Package name") - "pkg_name" - (fun () -> (pkg_get ()).name) - - let pkg_version = - var_define - ~short_desc:(fun () -> s_ "Package version") - "pkg_version" - (fun () -> - (OASISVersion.string_of_version (pkg_get ()).version)) - - let c = BaseOCamlcConfig.var_define - - let os_type = c "os_type" - let system = c "system" - let architecture = c "architecture" - let ccomp_type = c "ccomp_type" - let ocaml_version = c "ocaml_version" - - (* TODO: Check standard variable presence at runtime *) - - let standard_library_default = c "standard_library_default" - let standard_library = c "standard_library" - let standard_runtime = c "standard_runtime" - let bytecomp_c_compiler = c "bytecomp_c_compiler" - let native_c_compiler = c "native_c_compiler" - let model = c "model" - let ext_obj = c "ext_obj" - let ext_asm = c "ext_asm" - let ext_lib = c "ext_lib" - let ext_dll = c "ext_dll" - let default_executable_name = c "default_executable_name" - let systhread_supported = c "systhread_supported" - - let flexlink = - BaseCheck.prog "flexlink" - - let flexdll_version = - var_define - ~short_desc:(fun () -> "FlexDLL version (Win32)") - "flexdll_version" - (fun () -> - let lst = - OASISExec.run_read_output ~ctxt:!BaseContext.default - (flexlink ()) ["-help"] - in - match lst with - | line :: _ -> - Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) - | [] -> - raise Not_found) - - (**/**) - let p name hlp dflt = - var_define - ~short_desc:hlp - ~cli:CLIAuto - ~arg_help:"dir" - name - dflt - - let (/) a b = - if os_type () = Sys.os_type then - Filename.concat a b - else if os_type () = "Unix" then - OASISUnixPath.concat a b - else - OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") - (os_type ()) - (**/**) - - let prefix = - p "prefix" - (fun () -> s_ "Install architecture-independent files dir") - (fun () -> - match os_type () with - | "Win32" -> - let program_files = - Sys.getenv "PROGRAMFILES" - in - program_files/(pkg_name ()) - | _ -> - "/usr/local") - - let exec_prefix = - p "exec_prefix" - (fun () -> s_ "Install architecture-dependent files in dir") - (fun () -> "$prefix") - - let bindir = - p "bindir" - (fun () -> s_ "User executables") - (fun () -> "$exec_prefix"/"bin") - - let sbindir = - p "sbindir" - (fun () -> s_ "System admin executables") - (fun () -> "$exec_prefix"/"sbin") - - let libexecdir = - p "libexecdir" - (fun () -> s_ "Program executables") - (fun () -> "$exec_prefix"/"libexec") - - let sysconfdir = - p "sysconfdir" - (fun () -> s_ "Read-only single-machine data") - (fun () -> "$prefix"/"etc") - - let sharedstatedir = - p "sharedstatedir" - (fun () -> s_ "Modifiable architecture-independent data") - (fun () -> "$prefix"/"com") - - let localstatedir = - p "localstatedir" - (fun () -> s_ "Modifiable single-machine data") - (fun () -> "$prefix"/"var") - - let libdir = - p "libdir" - (fun () -> s_ "Object code libraries") - (fun () -> "$exec_prefix"/"lib") - - let datarootdir = - p "datarootdir" - (fun () -> s_ "Read-only arch-independent data root") - (fun () -> "$prefix"/"share") - - let datadir = - p "datadir" - (fun () -> s_ "Read-only architecture-independent data") - (fun () -> "$datarootdir") - - let infodir = - p "infodir" - (fun () -> s_ "Info documentation") - (fun () -> "$datarootdir"/"info") - - let localedir = - p "localedir" - (fun () -> s_ "Locale-dependent data") - (fun () -> "$datarootdir"/"locale") - - let mandir = - p "mandir" - (fun () -> s_ "Man documentation") - (fun () -> "$datarootdir"/"man") - - let docdir = - p "docdir" - (fun () -> s_ "Documentation root") - (fun () -> "$datarootdir"/"doc"/"$pkg_name") - - let htmldir = - p "htmldir" - (fun () -> s_ "HTML documentation") - (fun () -> "$docdir") - - let dvidir = - p "dvidir" - (fun () -> s_ "DVI documentation") - (fun () -> "$docdir") - - let pdfdir = - p "pdfdir" - (fun () -> s_ "PDF documentation") - (fun () -> "$docdir") - - let psdir = - p "psdir" - (fun () -> s_ "PS documentation") - (fun () -> "$docdir") - - let destdir = - p "destdir" - (fun () -> s_ "Prepend a path when installing package") - (fun () -> - raise - (PropList.Not_set - ("destdir", - Some (s_ "undefined by construct")))) - - let findlib_version = - var_define - "findlib_version" - (fun () -> - BaseCheck.package_version "findlib") - - let is_native = - var_define - "is_native" - (fun () -> - try - let _s : string = - ocamlopt () - in - "true" - with PropList.Not_set _ -> - let _s : string = - ocamlc () - in - "false") - - let ext_program = - var_define - "suffix_program" - (fun () -> - match os_type () with - | "Win32" -> ".exe" - | _ -> "") - - let rm = - var_define - ~short_desc:(fun () -> s_ "Remove a file.") - "rm" - (fun () -> - match os_type () with - | "Win32" -> "del" - | _ -> "rm -f") - - let rmdir = - var_define - ~short_desc:(fun () -> s_ "Remove a directory.") - "rmdir" - (fun () -> - match os_type () with - | "Win32" -> "rd" - | _ -> "rm -rf") - - let debug = - var_define - ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") - ~cli:CLIEnable - "debug" - (fun () -> "true") - - let profile = - var_define - ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") - ~cli:CLIEnable - "profile" - (fun () -> "false") - - let tests = - var_define_cond ~since_version:"0.3" - (fun () -> - var_define - ~short_desc:(fun () -> - s_ "Compile tests executable and library and run them") - ~cli:CLIEnable - "tests" - (fun () -> "false")) - "true" - - let docs = - var_define_cond ~since_version:"0.3" - (fun () -> - var_define - ~short_desc:(fun () -> s_ "Create documentations") - ~cli:CLIEnable - "docs" - (fun () -> "true")) - "true" - - let native_dynlink = - var_define - ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") - ~cli:CLINone - "native_dynlink" - (fun () -> - let res = - let ocaml_lt_312 () = - OASISVersion.comparator_apply - (OASISVersion.version_of_string (ocaml_version ())) - (OASISVersion.VLesser - (OASISVersion.version_of_string "3.12.0")) - in - let flexdll_lt_030 () = - OASISVersion.comparator_apply - (OASISVersion.version_of_string (flexdll_version ())) - (OASISVersion.VLesser - (OASISVersion.version_of_string "0.30")) - in - let has_native_dynlink = - let ocamlfind = ocamlfind () in - try - let fn = - OASISExec.run_read_one_line - ~ctxt:!BaseContext.default - ocamlfind - ["query"; "-predicates"; "native"; "dynlink"; - "-format"; "%d/%a"] - in - Sys.file_exists fn - with _ -> - false - in - if not has_native_dynlink then - false - else if ocaml_lt_312 () then - false - else if (os_type () = "Win32" || os_type () = "Cygwin") - && flexdll_lt_030 () then - begin - BaseMessage.warning - (f_ ".cmxs generation disabled because FlexDLL needs to be \ - at least 0.30. Please upgrade FlexDLL from %s to 0.30.") - (flexdll_version ()); - false - end - else - true - in - string_of_bool res) - - let init pkg = - rpkg := Some pkg; - List.iter (fun f -> f pkg.oasis_version) !var_cond - -end - -module BaseFileAB = struct -(* # 21 "src/base/BaseFileAB.ml" *) - - open BaseEnv - open OASISGettext - open BaseMessage - - let to_filename fn = - let fn = - OASISHostPath.of_unix fn - in - if not (Filename.check_suffix fn ".ab") then - warning - (f_ "File '%s' doesn't have '.ab' extension") - fn; - Filename.chop_extension fn - - let replace fn_lst = - let buff = - Buffer.create 13 - in - List.iter - (fun fn -> - let fn = - OASISHostPath.of_unix fn - in - let chn_in = - open_in fn - in - let chn_out = - open_out (to_filename fn) - in - ( - try - while true do - Buffer.add_string buff (var_expand (input_line chn_in)); - Buffer.add_char buff '\n' - done - with End_of_file -> - () - ); - Buffer.output_buffer chn_out buff; - Buffer.clear buff; - close_in chn_in; - close_out chn_out) - fn_lst -end - -module BaseLog = struct -(* # 21 "src/base/BaseLog.ml" *) - - open OASISUtils - - let default_filename = - Filename.concat - (Filename.dirname BaseEnv.default_filename) - "setup.log" - - module SetTupleString = - Set.Make - (struct - type t = string * string - let compare (s11, s12) (s21, s22) = - match String.compare s11 s21 with - | 0 -> String.compare s12 s22 - | n -> n - end) - - let load () = - if Sys.file_exists default_filename then - begin - let chn = - open_in default_filename - in - let scbuf = - Scanf.Scanning.from_file default_filename - in - let rec read_aux (st, lst) = - if not (Scanf.Scanning.end_of_input scbuf) then - begin - let acc = - try - Scanf.bscanf scbuf "%S %S\n" - (fun e d -> - let t = - e, d - in - if SetTupleString.mem t st then - st, lst - else - SetTupleString.add t st, - t :: lst) - with Scanf.Scan_failure _ -> - failwith - (Scanf.bscanf scbuf - "%l" - (fun line -> - Printf.sprintf - "Malformed log file '%s' at line %d" - default_filename - line)) - in - read_aux acc - end - else - begin - close_in chn; - List.rev lst - end - in - read_aux (SetTupleString.empty, []) - end - else - begin - [] - end - - let register event data = - let chn_out = - open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename - in - Printf.fprintf chn_out "%S %S\n" event data; - close_out chn_out - - let unregister event data = - if Sys.file_exists default_filename then - begin - let lst = - load () - in - let chn_out = - open_out default_filename - in - let write_something = - ref false - in - List.iter - (fun (e, d) -> - if e <> event || d <> data then - begin - write_something := true; - Printf.fprintf chn_out "%S %S\n" e d - end) - lst; - close_out chn_out; - if not !write_something then - Sys.remove default_filename - end - - let filter events = - let st_events = - List.fold_left - (fun st e -> - SetString.add e st) - SetString.empty - events - in - List.filter - (fun (e, _) -> SetString.mem e st_events) - (load ()) - - let exists event data = - List.exists - (fun v -> (event, data) = v) - (load ()) -end - -module BaseBuilt = struct -(* # 21 "src/base/BaseBuilt.ml" *) - - open OASISTypes - open OASISGettext - open BaseStandardVar - open BaseMessage - - type t = - | BExec (* Executable *) - | BExecLib (* Library coming with executable *) - | BLib (* Library *) - | BDoc (* Document *) - - let to_log_event_file t nm = - "built_"^ - (match t with - | BExec -> "exec" - | BExecLib -> "exec_lib" - | BLib -> "lib" - | BDoc -> "doc")^ - "_"^nm - - let to_log_event_done t nm = - "is_"^(to_log_event_file t nm) - - let register t nm lst = - BaseLog.register - (to_log_event_done t nm) - "true"; - List.iter - (fun alt -> - let registered = - List.fold_left - (fun registered fn -> - if OASISFileUtil.file_exists_case fn then - begin - BaseLog.register - (to_log_event_file t nm) - (if Filename.is_relative fn then - Filename.concat (Sys.getcwd ()) fn - else - fn); - true - end - else - registered) - false - alt - in - if not registered then - warning - (f_ "Cannot find an existing alternative files among: %s") - (String.concat (s_ ", ") alt)) - lst - - let unregister t nm = - List.iter - (fun (e, d) -> - BaseLog.unregister e d) - (BaseLog.filter - [to_log_event_file t nm; - to_log_event_done t nm]) - - let fold t nm f acc = - List.fold_left - (fun acc (_, fn) -> - if OASISFileUtil.file_exists_case fn then - begin - f acc fn - end - else - begin - warning - (f_ "File '%s' has been marked as built \ - for %s but doesn't exist") - fn - (Printf.sprintf - (match t with - | BExec | BExecLib -> - (f_ "executable %s") - | BLib -> - (f_ "library %s") - | BDoc -> - (f_ "documentation %s")) - nm); - acc - end) - acc - (BaseLog.filter - [to_log_event_file t nm]) - - let is_built t nm = - List.fold_left - (fun is_built (_, d) -> - (try - bool_of_string d - with _ -> - false)) - false - (BaseLog.filter - [to_log_event_done t nm]) - - let of_executable ffn (cs, bs, exec) = - let unix_exec_is, unix_dll_opt = - OASISExecutable.unix_exec_is - (cs, bs, exec) - (fun () -> - bool_of_string - (is_native ())) - ext_dll - ext_program - in - let evs = - (BExec, cs.cs_name, [[ffn unix_exec_is]]) - :: - (match unix_dll_opt with - | Some fn -> - [BExecLib, cs.cs_name, [[ffn fn]]] - | None -> - []) - in - evs, - unix_exec_is, - unix_dll_opt - - let of_library ffn (cs, bs, lib) = - let unix_lst = - OASISLibrary.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 ())) - ~has_native_dynlink:(bool_of_string (native_dynlink ())) - ~ext_lib:(ext_lib ()) - ~ext_dll:(ext_dll ()) - (cs, bs, lib) - in - let evs = - [BLib, - cs.cs_name, - List.map (List.map ffn) unix_lst] - in - evs, unix_lst - -end - -module BaseCustom = struct -(* # 21 "src/base/BaseCustom.ml" *) - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISGettext - - let run cmd args extra_args = - OASISExec.run ~ctxt:!BaseContext.default ~quote:false - (var_expand cmd) - (List.map - var_expand - (args @ (Array.to_list extra_args))) - - let hook ?(failsafe=false) cstm f e = - let optional_command lst = - let printer = - function - | Some (cmd, args) -> String.concat " " (cmd :: args) - | None -> s_ "No command" - in - match - var_choose - ~name:(s_ "Pre/Post Command") - ~printer - lst with - | Some (cmd, args) -> - begin - try - run cmd args [||] - with e when failsafe -> - warning - (f_ "Command '%s' fail with error: %s") - (String.concat " " (cmd :: args)) - (match e with - | Failure msg -> msg - | e -> Printexc.to_string e) - end - | None -> - () - in - let res = - optional_command cstm.pre_command; - f e - in - optional_command cstm.post_command; - res -end - -module BaseDynVar = struct -(* # 21 "src/base/BaseDynVar.ml" *) - - - open OASISTypes - open OASISGettext - open BaseEnv - open BaseBuilt - - let init pkg = - (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) - (* TODO: provide compile option for library libary_byte_args_VARNAME... *) - List.iter - (function - | Executable (cs, bs, exec) -> - if var_choose bs.bs_build then - var_ignore - (var_redefine - (* We don't save this variable *) - ~dump:false - ~short_desc:(fun () -> - Printf.sprintf - (f_ "Filename of executable '%s'") - cs.cs_name) - (OASISUtils.varname_of_string cs.cs_name) - (fun () -> - let fn_opt = - fold - BExec cs.cs_name - (fun _ fn -> Some fn) - None - in - match fn_opt with - | Some fn -> fn - | None -> - raise - (PropList.Not_set - (cs.cs_name, - Some (Printf.sprintf - (f_ "Executable '%s' not yet built.") - cs.cs_name))))) - - | Library _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> - ()) - pkg.sections -end - -module BaseTest = struct -(* # 21 "src/base/BaseTest.ml" *) - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISExpr - open OASISGettext - - let test lst pkg extra_args = - - let one_test (failure, n) (test_plugin, cs, test) = - if var_choose - ~name:(Printf.sprintf - (f_ "test %s run") - cs.cs_name) - ~printer:string_of_bool - test.test_run then - begin - let () = - info (f_ "Running test '%s'") cs.cs_name - in - let back_cwd = - match test.test_working_directory with - | Some dir -> - let cwd = - Sys.getcwd () - in - let chdir d = - info (f_ "Changing directory to '%s'") d; - Sys.chdir d - in - chdir dir; - fun () -> chdir cwd - - | None -> - fun () -> () - in - try - let failure_percent = - BaseCustom.hook - test.test_custom - (test_plugin pkg (cs, test)) - extra_args - in - back_cwd (); - (failure_percent +. failure, n + 1) - with e -> - begin - back_cwd (); - raise e - end - end - else - begin - info (f_ "Skipping test '%s'") cs.cs_name; - (failure, n) - end - in - let (failed, n) = - List.fold_left - one_test - (0.0, 0) - lst - in - let failure_percent = - if n = 0 then - 0.0 - else - failed /. (float_of_int n) - in - let msg = - Printf.sprintf - (f_ "Tests had a %.2f%% failure rate") - (100. *. failure_percent) - in - if failure_percent > 0.0 then - failwith msg - else - info "%s" msg; - - (* Possible explanation why the tests where not run. *) - if OASISVersion.version_0_3_or_after pkg.oasis_version && - not (bool_of_string (BaseStandardVar.tests ())) && - lst <> [] then - BaseMessage.warning - "Tests are turned off, consider enabling with \ - 'ocaml setup.ml -configure --enable-tests'" -end - -module BaseDoc = struct -(* # 21 "src/base/BaseDoc.ml" *) - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISGettext - - let doc lst pkg extra_args = - - let one_doc (doc_plugin, cs, doc) = - if var_choose - ~name:(Printf.sprintf - (f_ "documentation %s build") - cs.cs_name) - ~printer:string_of_bool - doc.doc_build then - begin - info (f_ "Building documentation '%s'") cs.cs_name; - BaseCustom.hook - doc.doc_custom - (doc_plugin pkg (cs, doc)) - extra_args - end - in - List.iter one_doc lst; - - if OASISVersion.version_0_3_or_after pkg.oasis_version && - not (bool_of_string (BaseStandardVar.docs ())) && - lst <> [] then - BaseMessage.warning - "Docs are turned off, consider enabling with \ - 'ocaml setup.ml -configure --enable-docs'" -end - -module BaseSetup = struct -(* # 21 "src/base/BaseSetup.ml" *) - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISSection - open OASISGettext - open OASISUtils - - type std_args_fun = - package -> string array -> unit - - type ('a, 'b) section_args_fun = - name * (package -> (common_section * 'a) -> string array -> 'b) - - type t = - { - configure: std_args_fun; - build: std_args_fun; - doc: ((doc, unit) section_args_fun) list; - test: ((test, float) section_args_fun) list; - install: std_args_fun; - uninstall: std_args_fun; - clean: std_args_fun list; - clean_doc: (doc, unit) section_args_fun list; - clean_test: (test, unit) section_args_fun list; - distclean: std_args_fun list; - distclean_doc: (doc, unit) section_args_fun list; - distclean_test: (test, unit) section_args_fun list; - package: package; - oasis_fn: string option; - oasis_version: string; - oasis_digest: Digest.t option; - oasis_exec: string option; - oasis_setup_args: string list; - setup_update: bool; - } - - (* Associate a plugin function with data from package *) - let join_plugin_sections filter_map lst = - List.rev - (List.fold_left - (fun acc sct -> - match filter_map sct with - | Some e -> - e :: acc - | None -> - acc) - [] - lst) - - (* Search for plugin data associated with a section name *) - let lookup_plugin_section plugin action nm lst = - try - List.assoc nm lst - with Not_found -> - failwithf - (f_ "Cannot find plugin %s matching section %s for %s action") - plugin - nm - action - - let configure t args = - (* Run configure *) - BaseCustom.hook - t.package.conf_custom - (fun () -> - (* Reload if preconf has changed it *) - begin - try - unload (); - load (); - with _ -> - () - end; - - (* Run plugin's configure *) - t.configure t.package args; - - (* Dump to allow postconf to change it *) - dump ()) - (); - - (* Reload environment *) - unload (); - load (); - - (* Save environment *) - print (); - - (* Replace data in file *) - BaseFileAB.replace t.package.files_ab - - let build t args = - BaseCustom.hook - t.package.build_custom - (t.build t.package) - args - - let doc t args = - BaseDoc.doc - (join_plugin_sections - (function - | Doc (cs, e) -> - Some - (lookup_plugin_section - "documentation" - (s_ "build") - cs.cs_name - t.doc, - cs, - e) - | _ -> - None) - t.package.sections) - t.package - args - - let test t args = - BaseTest.test - (join_plugin_sections - (function - | Test (cs, e) -> - Some - (lookup_plugin_section - "test" - (s_ "run") - cs.cs_name - t.test, - cs, - e) - | _ -> - None) - t.package.sections) - t.package - args - - let all t args = - let rno_doc = - ref false - in - let rno_test = - ref false - in - Arg.parse_argv - ~current:(ref 0) - (Array.of_list - ((Sys.executable_name^" all") :: - (Array.to_list args))) - [ - "-no-doc", - Arg.Set rno_doc, - s_ "Don't run doc target"; - - "-no-test", - Arg.Set rno_test, - s_ "Don't run test target"; - ] - (failwithf (f_ "Don't know what to do with '%s'")) - ""; - - info "Running configure step"; - configure t [||]; - - info "Running build step"; - build t [||]; - - (* Load setup.log dynamic variables *) - BaseDynVar.init t.package; - - if not !rno_doc then - begin - info "Running doc step"; - doc t [||]; - end - else - begin - info "Skipping doc step" - end; - - if not !rno_test then - begin - info "Running test step"; - test t [||] - end - else - begin - info "Skipping test step" - end - - let install t args = - BaseCustom.hook - t.package.install_custom - (t.install t.package) - args - - let uninstall t args = - BaseCustom.hook - t.package.uninstall_custom - (t.uninstall t.package) - args - - let reinstall t args = - uninstall t args; - install t args - - let clean, distclean = - let failsafe f a = - try - f a - with e -> - warning - (f_ "Action fail with error: %s") - (match e with - | Failure msg -> msg - | e -> Printexc.to_string e) - in - - let generic_clean t cstm mains docs tests args = - BaseCustom.hook - ~failsafe:true - cstm - (fun () -> - (* Clean section *) - List.iter - (function - | Test (cs, test) -> - let f = - try - List.assoc cs.cs_name tests - with Not_found -> - fun _ _ _ -> () - in - failsafe - (f t.package (cs, test)) - args - | Doc (cs, doc) -> - let f = - try - List.assoc cs.cs_name docs - with Not_found -> - fun _ _ _ -> () - in - failsafe - (f t.package (cs, doc)) - args - | Library _ - | Executable _ - | Flag _ - | SrcRepo _ -> - ()) - t.package.sections; - (* Clean whole package *) - List.iter - (fun f -> - failsafe - (f t.package) - args) - mains) - () - in - - let clean t args = - generic_clean - t - t.package.clean_custom - t.clean - t.clean_doc - t.clean_test - args - in - - let distclean t args = - (* Call clean *) - clean t args; - - (* Call distclean code *) - generic_clean - t - t.package.distclean_custom - t.distclean - t.distclean_doc - t.distclean_test - args; - - (* Remove generated file *) - List.iter - (fun fn -> - if Sys.file_exists fn then - begin - info (f_ "Remove '%s'") fn; - Sys.remove fn - end) - (BaseEnv.default_filename - :: - BaseLog.default_filename - :: - (List.rev_map BaseFileAB.to_filename t.package.files_ab)) - in - - clean, distclean - - let version t _ = - print_endline t.oasis_version - - let update_setup_ml, no_update_setup_ml_cli = - let b = ref true in - b, - ("-no-update-setup-ml", - Arg.Clear b, - s_ " Don't try to update setup.ml, even if _oasis has changed.") - - let update_setup_ml t = - let oasis_fn = - match t.oasis_fn with - | Some fn -> fn - | None -> "_oasis" - in - let oasis_exec = - match t.oasis_exec with - | Some fn -> fn - | None -> "oasis" - in - let ocaml = - Sys.executable_name - in - let setup_ml, args = - match Array.to_list Sys.argv with - | setup_ml :: args -> - setup_ml, args - | [] -> - failwith - (s_ "Expecting non-empty command line arguments.") - in - let ocaml, setup_ml = - if Sys.executable_name = Sys.argv.(0) then - (* We are not running in standard mode, probably the script - * is precompiled. - *) - "ocaml", "setup.ml" - else - ocaml, setup_ml - in - let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in - let do_update () = - let oasis_exec_version = - OASISExec.run_read_one_line - ~ctxt:!BaseContext.default - ~f_exit_code: - (function - | 0 -> - () - | 1 -> - failwithf - (f_ "Executable '%s' is probably an old version \ - of oasis (< 0.3.0), please update to version \ - v%s.") - oasis_exec t.oasis_version - | 127 -> - failwithf - (f_ "Cannot find executable '%s', please install \ - oasis v%s.") - oasis_exec t.oasis_version - | n -> - failwithf - (f_ "Command '%s version' exited with code %d.") - oasis_exec n) - oasis_exec ["version"] - in - if OASISVersion.comparator_apply - (OASISVersion.version_of_string oasis_exec_version) - (OASISVersion.VGreaterEqual - (OASISVersion.version_of_string t.oasis_version)) then - begin - (* We have a version >= for the executable oasis, proceed with - * update. - *) - (* TODO: delegate this check to 'oasis setup'. *) - if Sys.os_type = "Win32" then - failwithf - (f_ "It is not possible to update the running script \ - setup.ml on Windows. Please update setup.ml by \ - running '%s'.") - (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) - else - begin - OASISExec.run - ~ctxt:!BaseContext.default - ~f_exit_code: - (function - | 0 -> - () - | n -> - failwithf - (f_ "Unable to update setup.ml using '%s', \ - please fix the problem and retry.") - oasis_exec) - oasis_exec ("setup" :: t.oasis_setup_args); - OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) - end - end - else - failwithf - (f_ "The version of '%s' (v%s) doesn't match the version of \ - oasis used to generate the %s file. Please install at \ - least oasis v%s.") - oasis_exec oasis_exec_version setup_ml t.oasis_version - in - - if !update_setup_ml then - begin - try - match t.oasis_digest with - | Some dgst -> - if Sys.file_exists oasis_fn && dgst <> Digest.file "_oasis" then - begin - do_update (); - true - end - else - false - | None -> - false - with e -> - error - (f_ "Error when updating setup.ml. If you want to avoid this error, \ - you can bypass the update of %s by running '%s %s %s %s'") - setup_ml ocaml setup_ml no_update_setup_ml_cli - (String.concat " " args); - raise e - end - else - false - - let setup t = - let catch_exn = - ref true - in - try - let act_ref = - ref (fun _ -> - failwithf - (f_ "No action defined, run '%s %s -help'") - Sys.executable_name - Sys.argv.(0)) - - in - let extra_args_ref = - ref [] - in - let allow_empty_env_ref = - ref false - in - let arg_handle ?(allow_empty_env=false) act = - Arg.Tuple - [ - Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); - - Arg.Unit - (fun () -> - allow_empty_env_ref := allow_empty_env; - act_ref := act); - ] - in - - Arg.parse - (Arg.align - ([ - "-configure", - arg_handle ~allow_empty_env:true configure, - s_ "[options*] Configure the whole build process."; - - "-build", - arg_handle build, - s_ "[options*] Build executables and libraries."; - - "-doc", - arg_handle doc, - s_ "[options*] Build documents."; - - "-test", - arg_handle test, - s_ "[options*] Run tests."; - - "-all", - arg_handle ~allow_empty_env:true all, - s_ "[options*] Run configure, build, doc and test targets."; - - "-install", - arg_handle install, - s_ "[options*] Install libraries, data, executables \ - and documents."; - - "-uninstall", - arg_handle uninstall, - s_ "[options*] Uninstall libraries, data, executables \ - and documents."; - - "-reinstall", - arg_handle reinstall, - s_ "[options*] Uninstall and install libraries, data, \ - executables and documents."; - - "-clean", - arg_handle ~allow_empty_env:true clean, - s_ "[options*] Clean files generated by a build."; - - "-distclean", - arg_handle ~allow_empty_env:true distclean, - s_ "[options*] Clean files generated by a build and configure."; - - "-version", - arg_handle ~allow_empty_env:true version, - s_ " Display version of OASIS used to generate this setup.ml."; - - "-no-catch-exn", - Arg.Clear catch_exn, - s_ " Don't catch exception, useful for debugging."; - ] - @ - (if t.setup_update then - [no_update_setup_ml_cli] - else - []) - @ (BaseContext.args ()))) - (failwithf (f_ "Don't know what to do with '%s'")) - (s_ "Setup and run build process current package\n"); - - (* Build initial environment *) - load ~allow_empty:!allow_empty_env_ref (); - - (** Initialize flags *) - List.iter - (function - | Flag (cs, {flag_description = hlp; - flag_default = choices}) -> - begin - let apply ?short_desc () = - var_ignore - (var_define - ~cli:CLIEnable - ?short_desc - (OASISUtils.varname_of_string cs.cs_name) - (fun () -> - string_of_bool - (var_choose - ~name:(Printf.sprintf - (f_ "default value of flag %s") - cs.cs_name) - ~printer:string_of_bool - choices))) - in - match hlp with - | Some hlp -> - apply ~short_desc:(fun () -> hlp) () - | None -> - apply () - end - | _ -> - ()) - t.package.sections; - - BaseStandardVar.init t.package; - - BaseDynVar.init t.package; - - if t.setup_update && update_setup_ml t then - () - else - !act_ref t (Array.of_list (List.rev !extra_args_ref)) - - with e when !catch_exn -> - error "%s" (Printexc.to_string e); - exit 1 - -end - - -# 4480 "setup.ml" -module InternalConfigurePlugin = struct -(* # 21 "src/plugins/internal/InternalConfigurePlugin.ml" *) - - (** Configure using internal scheme - @author Sylvain Le Gall - *) - - open BaseEnv - open OASISTypes - open OASISUtils - open OASISGettext - open BaseMessage - - (** Configure build using provided series of check to be done - * and then output corresponding file. - *) - let configure pkg argv = - let var_ignore_eval var = - let _s : string = - var () - in - () - in - - let errors = - ref SetString.empty - in - - let buff = - Buffer.create 13 - in - - let add_errors fmt = - Printf.kbprintf - (fun b -> - errors := SetString.add (Buffer.contents b) !errors; - Buffer.clear b) - buff - fmt - in - - let warn_exception e = - warning "%s" (Printexc.to_string e) - in - - (* Check tools *) - let check_tools lst = - List.iter - (function - | ExternalTool tool -> - begin - try - var_ignore_eval (BaseCheck.prog tool) - with e -> - warn_exception e; - add_errors (f_ "Cannot find external tool '%s'") tool - end - | InternalExecutable nm1 -> - (* Check that matching tool is built *) - List.iter - (function - | Executable ({cs_name = nm2}, - {bs_build = build}, - _) when nm1 = nm2 -> - if not (var_choose build) then - add_errors - (f_ "Cannot find buildable internal executable \ - '%s' when checking build depends") - nm1 - | _ -> - ()) - pkg.sections) - lst - in - - let build_checks sct bs = - if var_choose bs.bs_build then - begin - if bs.bs_compiled_object = Native then - begin - try - var_ignore_eval BaseStandardVar.ocamlopt - with e -> - warn_exception e; - add_errors - (f_ "Section %s requires native compilation") - (OASISSection.string_of_section sct) - end; - - (* Check tools *) - check_tools bs.bs_build_tools; - - (* Check depends *) - List.iter - (function - | FindlibPackage (findlib_pkg, version_comparator) -> - begin - try - var_ignore_eval - (BaseCheck.package ?version_comparator findlib_pkg) - with e -> - warn_exception e; - match version_comparator with - | None -> - add_errors - (f_ "Cannot find findlib package %s") - findlib_pkg - | Some ver_cmp -> - add_errors - (f_ "Cannot find findlib package %s (%s)") - findlib_pkg - (OASISVersion.string_of_comparator ver_cmp) - end - | InternalLibrary nm1 -> - (* Check that matching library is built *) - List.iter - (function - | Library ({cs_name = nm2}, - {bs_build = build}, - _) when nm1 = nm2 -> - if not (var_choose build) then - add_errors - (f_ "Cannot find buildable internal library \ - '%s' when checking build depends") - nm1 - | _ -> - ()) - pkg.sections) - bs.bs_build_depends - end - in - - (* Parse command line *) - BaseArgExt.parse argv (BaseEnv.args ()); - - (* OCaml version *) - begin - match pkg.ocaml_version with - | Some ver_cmp -> - begin - try - var_ignore_eval - (BaseCheck.version - "ocaml" - ver_cmp - BaseStandardVar.ocaml_version) - with e -> - warn_exception e; - add_errors - (f_ "OCaml version %s doesn't match version constraint %s") - (BaseStandardVar.ocaml_version ()) - (OASISVersion.string_of_comparator ver_cmp) - end - | None -> - () - end; - - (* Findlib version *) - begin - match pkg.findlib_version with - | Some ver_cmp -> - begin - try - var_ignore_eval - (BaseCheck.version - "findlib" - ver_cmp - BaseStandardVar.findlib_version) - with e -> - warn_exception e; - add_errors - (f_ "Findlib version %s doesn't match version constraint %s") - (BaseStandardVar.findlib_version ()) - (OASISVersion.string_of_comparator ver_cmp) - end - | None -> - () - end; - - (* FlexDLL *) - if BaseStandardVar.os_type () = "Win32" || - BaseStandardVar.os_type () = "Cygwin" then - begin - try - var_ignore_eval BaseStandardVar.flexlink - with e -> - warn_exception e; - add_errors (f_ "Cannot find 'flexlink'") - end; - - (* Check build depends *) - List.iter - (function - | Executable (_, bs, _) - | Library (_, bs, _) as sct -> - build_checks sct bs - | Doc (_, doc) -> - if var_choose doc.doc_build then - check_tools doc.doc_build_tools - | Test (_, test) -> - if var_choose test.test_run then - check_tools test.test_tools - | _ -> - ()) - pkg.sections; - - (* Check if we need native dynlink (presence of libraries that compile to - * native) - *) - begin - let has_cmxa = - List.exists - (function - | Library (_, bs, _) -> - var_choose bs.bs_build && - (bs.bs_compiled_object = Native || - (bs.bs_compiled_object = Best && - bool_of_string (BaseStandardVar.is_native ()))) - | _ -> - false) - pkg.sections - in - if has_cmxa then - var_ignore_eval BaseStandardVar.native_dynlink - end; - - (* Check errors *) - if SetString.empty != !errors then - begin - List.iter - (fun e -> error "%s" e) - (SetString.elements !errors); - failwithf - (fn_ - "%d configuration error" - "%d configuration errors" - (SetString.cardinal !errors)) - (SetString.cardinal !errors) - end - -end - -module InternalInstallPlugin = struct -(* # 21 "src/plugins/internal/InternalInstallPlugin.ml" *) - - (** Install using internal scheme - @author Sylvain Le Gall - *) - - open BaseEnv - open BaseStandardVar - open BaseMessage - open OASISTypes - open OASISLibrary - open OASISGettext - open OASISUtils - - let exec_hook = - ref (fun (cs, bs, exec) -> cs, bs, exec) - - let lib_hook = - ref (fun (cs, bs, lib) -> cs, bs, lib, []) - - let doc_hook = - ref (fun (cs, doc) -> cs, doc) - - let install_file_ev = - "install-file" - - let install_dir_ev = - "install-dir" - - let install_findlib_ev = - "install-findlib" - - let win32_max_command_line_length = 8000 - - let split_install_command ocamlfind findlib_name meta files = - if Sys.os_type = "Win32" then - (* Arguments for the first command: *) - let first_args = ["install"; findlib_name; meta] in - (* Arguments for remaining commands: *) - let other_args = ["install"; findlib_name; "-add"] in - (* Extract as much files as possible from [files], [len] is - the current command line length: *) - let rec get_files len acc files = - match files with - | [] -> - (List.rev acc, []) - | file :: rest -> - let len = len + 1 + String.length file in - if len > win32_max_command_line_length then - (List.rev acc, files) - else - get_files len (file :: acc) rest - in - (* Split the command into several commands. *) - let rec split args files = - match files with - | [] -> - [] - | _ -> - (* Length of "ocamlfind install [META|-add]" *) - let len = - List.fold_left - (fun len arg -> - len + 1 (* for the space *) + String.length arg) - (String.length ocamlfind) - args - in - match get_files len [] files with - | ([], _) -> - failwith (s_ "Command line too long.") - | (firsts, others) -> - let cmd = args @ firsts in - (* Use -add for remaining commands: *) - let () = - let findlib_ge_132 = - OASISVersion.comparator_apply - (OASISVersion.version_of_string - (BaseStandardVar.findlib_version ())) - (OASISVersion.VGreaterEqual - (OASISVersion.version_of_string "1.3.2")) - in - if not findlib_ge_132 then - failwithf - (f_ "Installing the library %s require to use the flag \ - '-add' of ocamlfind because the command line is too \ - long. This flag is only available for findlib 1.3.2. \ - Please upgrade findlib from %s to 1.3.2") - findlib_name (BaseStandardVar.findlib_version ()) - in - let cmds = split other_args others in - cmd :: cmds - in - (* The first command does not use -add: *) - split first_args files - else - ["install" :: findlib_name :: meta :: files] - - let install pkg argv = - - let in_destdir = - try - let destdir = - destdir () - in - (* Practically speaking destdir is prepended - * at the beginning of the target filename - *) - fun fn -> destdir^fn - with PropList.Not_set _ -> - fun fn -> fn - in - - let install_file ?tgt_fn src_file envdir = - let tgt_dir = - in_destdir (envdir ()) - in - let tgt_file = - Filename.concat - tgt_dir - (match tgt_fn with - | Some fn -> - fn - | None -> - Filename.basename src_file) - in - (* Create target directory if needed *) - OASISFileUtil.mkdir_parent - ~ctxt:!BaseContext.default - (fun dn -> - info (f_ "Creating directory '%s'") dn; - BaseLog.register install_dir_ev dn) - tgt_dir; - - (* Really install files *) - info (f_ "Copying file '%s' to '%s'") src_file tgt_file; - OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file; - BaseLog.register install_file_ev tgt_file - in - - (* Install data into defined directory *) - let install_data srcdir lst tgtdir = - let tgtdir = - OASISHostPath.of_unix (var_expand tgtdir) - in - List.iter - (fun (src, tgt_opt) -> - let real_srcs = - OASISFileUtil.glob - ~ctxt:!BaseContext.default - (Filename.concat srcdir src) - in - if real_srcs = [] then - failwithf - (f_ "Wildcard '%s' doesn't match any files") - src; - List.iter - (fun fn -> - install_file - fn - (fun () -> - match tgt_opt with - | Some s -> - OASISHostPath.of_unix (var_expand s) - | None -> - tgtdir)) - real_srcs) - lst - in - - (** Install all libraries *) - let install_libs pkg = - - let files_of_library (f_data, acc) data_lib = - let cs, bs, lib, lib_extra = - !lib_hook data_lib - in - if var_choose bs.bs_install && - BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then - begin - let acc = - (* Start with acc + lib_extra *) - List.rev_append lib_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 library %s") - modul cs.cs_name; - acc - end) - acc - lib.lib_modules - in - - let acc = - (* Get generated files *) - BaseBuilt.fold - BaseBuilt.BLib - cs.cs_name - (fun acc fn -> fn :: acc) - acc - in - - let f_data () = - (* Install data associated with the library *) - 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 *) - let install_group_lib grp = - (* Iterate through all group nodes *) - let rec install_group_lib_aux data_and_files grp = - let data_and_files, children = - match grp with - | Container (_, children) -> - data_and_files, children - | Package (_, cs, bs, lib, children) -> - files_of_library data_and_files (cs, bs, lib), children - in - List.fold_left - install_group_lib_aux - data_and_files - children - in - - (* Findlib name of the root library *) - let findlib_name = - findlib_of_group grp - in - - (* Determine root library *) - let root_lib = - root_of_group grp - in - - (* All files to install for this library *) - let f_data, files = - install_group_lib_aux (ignore, []) grp - in - - (* Really install, if there is something to install *) - if files = [] then - begin - warning - (f_ "Nothing to install for findlib library '%s'") - findlib_name - end - else - begin - let meta = - (* Search META file *) - let (_, bs, _) = - root_lib - in - let res = - Filename.concat bs.bs_path "META" - in - if not (OASISFileUtil.file_exists_case res) then - failwithf - (f_ "Cannot find file '%s' for findlib library %s") - res - findlib_name; - res - in - let files = - (* Make filename shorter to avoid hitting command max line length - * too early, esp. on Windows. - *) - let remove_prefix p n = - let plen = String.length p in - let nlen = String.length n in - if plen <= nlen && String.sub n 0 plen = p then - begin - let fn_sep = - if Sys.os_type = "Win32" then - '\\' - else - '/' - in - let cutpoint = plen + - (if plen < nlen && n.[plen] = fn_sep then - 1 - else - 0) - in - String.sub n cutpoint (nlen - cutpoint) - end - else - n - in - List.map (remove_prefix (Sys.getcwd ())) files - in - info - (f_ "Installing findlib library '%s'") - findlib_name; - let ocamlfind = ocamlfind () in - let commands = - split_install_command - ocamlfind - findlib_name - meta - files - in - List.iter - (OASISExec.run ~ctxt:!BaseContext.default ocamlfind) - commands; - BaseLog.register install_findlib_ev findlib_name - end; - - (* Install data files *) - f_data (); - - in - - let group_libs, _, _ = - findlib_mapping pkg - in - - (* We install libraries in groups *) - List.iter install_group_lib group_libs - in - - let install_execs pkg = - let install_exec data_exec = - let (cs, bs, exec) = - !exec_hook data_exec - in - if var_choose bs.bs_install && - BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then - begin - let exec_libdir () = - Filename.concat - (libdir ()) - pkg.name - in - BaseBuilt.fold - BaseBuilt.BExec - cs.cs_name - (fun () fn -> - install_file - ~tgt_fn:(cs.cs_name ^ ext_program ()) - fn - bindir) - (); - BaseBuilt.fold - BaseBuilt.BExecLib - cs.cs_name - (fun () fn -> - install_file - fn - exec_libdir) - (); - install_data - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name) - end - in - List.iter - (function - | Executable (cs, bs, exec)-> - install_exec (cs, bs, exec) - | _ -> - ()) - pkg.sections - in - - let install_docs pkg = - let install_doc data = - let (cs, doc) = - !doc_hook data - in - if var_choose doc.doc_install && - BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then - begin - let tgt_dir = - OASISHostPath.of_unix (var_expand doc.doc_install_dir) - in - BaseBuilt.fold - BaseBuilt.BDoc - cs.cs_name - (fun () fn -> - install_file - fn - (fun () -> tgt_dir)) - (); - install_data - Filename.current_dir_name - doc.doc_data_files - doc.doc_install_dir - end - in - List.iter - (function - | Doc (cs, doc) -> - install_doc (cs, doc) - | _ -> - ()) - pkg.sections - in - - install_libs pkg; - install_execs pkg; - install_docs pkg - - (* Uninstall already installed data *) - let uninstall _ argv = - List.iter - (fun (ev, data) -> - if ev = install_file_ev then - begin - if OASISFileUtil.file_exists_case data then - begin - info - (f_ "Removing file '%s'") - data; - Sys.remove data - end - else - begin - warning - (f_ "File '%s' doesn't exist anymore") - data - end - end - else if ev = install_dir_ev then - begin - if Sys.file_exists data && Sys.is_directory data then - begin - if Sys.readdir data = [||] then - begin - info - (f_ "Removing directory '%s'") - data; - OASISFileUtil.rmdir ~ctxt:!BaseContext.default data - end - else - begin - warning - (f_ "Directory '%s' is not empty (%s)") - data - (String.concat - ", " - (Array.to_list - (Sys.readdir data))) - end - end - else - begin - warning - (f_ "Directory '%s' doesn't exist anymore") - data - end - end - else if ev = install_findlib_ev then - begin - info (f_ "Removing findlib library '%s'") data; - OASISExec.run ~ctxt:!BaseContext.default - (ocamlfind ()) ["remove"; data] - end - else - failwithf (f_ "Unknown log event '%s'") ev; - BaseLog.unregister ev data) - (* We process event in reverse order *) - (List.rev - (BaseLog.filter - [install_file_ev; - install_dir_ev; - install_findlib_ev;])) - -end - - -# 5233 "setup.ml" -module OCamlbuildCommon = struct -(* # 21 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) - - (** Functions common to OCamlbuild build and doc plugin - *) - - open OASISGettext - open BaseEnv - open BaseStandardVar - - let ocamlbuild_clean_ev = - "ocamlbuild-clean" - - let ocamlbuildflags = - var_define - ~short_desc:(fun () -> "OCamlbuild additional flags") - "ocamlbuildflags" - (fun () -> "") - - (** Fix special arguments depending on environment *) - let fix_args args extra_argv = - List.flatten - [ - if (os_type ()) = "Win32" then - [ - "-classic-display"; - "-no-log"; - "-no-links"; - "-install-lib-dir"; - (Filename.concat (standard_library ()) "ocamlbuild") - ] - else - []; - - if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then - [ - "-byte-plugin" - ] - else - []; - args; - - if bool_of_string (debug ()) then - ["-tag"; "debug"] - else - []; - - if bool_of_string (profile ()) then - ["-tag"; "profile"] - else - []; - - OASISString.nsplit (ocamlbuildflags ()) ' '; - - Array.to_list extra_argv; - ] - - (** Run 'ocamlbuild -clean' if not already done *) - let run_clean extra_argv = - let extra_cli = - String.concat " " (Array.to_list extra_argv) - in - (* Run if never called with these args *) - if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then - begin - OASISExec.run ~ctxt:!BaseContext.default - (ocamlbuild ()) (fix_args ["-clean"] extra_argv); - BaseLog.register ocamlbuild_clean_ev extra_cli; - at_exit - (fun () -> - try - BaseLog.unregister ocamlbuild_clean_ev extra_cli - with _ -> - ()) - end - - (** Run ocamlbuild, unregister all clean events *) - let run_ocamlbuild args extra_argv = - (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html - *) - OASISExec.run ~ctxt:!BaseContext.default - (ocamlbuild ()) (fix_args args extra_argv); - (* Remove any clean event, we must run it again *) - List.iter - (fun (e, d) -> BaseLog.unregister e d) - (BaseLog.filter [ocamlbuild_clean_ev]) - - (** Determine real build directory *) - let build_dir extra_argv = - let rec search_args dir = - function - | "-build-dir" :: dir :: tl -> - search_args dir tl - | _ :: tl -> - search_args dir tl - | [] -> - dir - in - search_args "_build" (fix_args [] extra_argv) - -end - -module OCamlbuildPlugin = struct -(* # 21 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) - - (** Build using ocamlbuild - @author Sylvain Le Gall - *) - - open OASISTypes - open OASISGettext - open OASISUtils - open BaseEnv - open OCamlbuildCommon - open BaseStandardVar - open BaseMessage - - let cond_targets_hook = - ref (fun lst -> lst) - - let build pkg argv = - - (* Return the filename in build directory *) - let in_build_dir fn = - Filename.concat - (build_dir argv) - fn - in - - (* Return the unix filename in host build directory *) - let in_build_dir_of_unix fn = - in_build_dir (OASISHostPath.of_unix fn) - in - - let cond_targets = - List.fold_left - (fun acc -> - function - | Library (cs, bs, lib) when var_choose bs.bs_build -> - begin - let evs, unix_files = - BaseBuilt.of_library - in_build_dir_of_unix - (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 - (fun l -> l <> []) - (List.map - (List.filter - (fun fn -> - ends_with ".cma" fn - || ends_with ".cmxs" fn - || ends_with ".cmxa" fn - || ends_with (ext_lib ()) fn - || ends_with (ext_dll ()) fn)) - unix_files)) - in - - match tgts with - | _ :: _ -> - (evs, tgts) :: acc - | [] -> - failwithf - (f_ "No possible ocamlbuild targets for library %s") - cs.cs_name - end - - | Executable (cs, bs, exec) when var_choose bs.bs_build -> - begin - let evs, unix_exec_is, unix_dll_opt = - BaseBuilt.of_executable - in_build_dir_of_unix - (cs, bs, exec) - in - - let target ext = - let unix_tgt = - (OASISUnixPath.concat - bs.bs_path - (OASISUnixPath.chop_extension - exec.exec_main_is))^ext - in - let evs = - (* Fix evs, we want to use the unix_tgt, without copying *) - List.map - (function - | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> - BaseBuilt.BExec, nm, [[in_build_dir_of_unix unix_tgt]] - | ev -> - ev) - evs - in - evs, [unix_tgt] - in - - (* Add executable *) - let acc = - 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 _ | Executable _ | Test _ - | SrcRepo _ | Flag _ | Doc _ -> - acc) - [] - (* Keep the pkg.sections ordered *) - (List.rev pkg.sections); - in - - (* Check and register built files *) - let check_and_register (bt, bnm, lst) = - List.iter - (fun fns -> - if not (List.exists OASISFileUtil.file_exists_case fns) then - failwithf - (f_ "No one of expected built files %s exists") - (String.concat (s_ ", ") (List.map (Printf.sprintf "'%s'") fns))) - lst; - (BaseBuilt.register bt bnm lst) - in - - let cond_targets = - (* Run the hook *) - !cond_targets_hook cond_targets - in - - (* Run a list of target... *) - run_ocamlbuild - (List.flatten - (List.map snd cond_targets)) - argv; - (* ... and register events *) - List.iter - check_and_register - (List.flatten (List.map fst cond_targets)) - - - let clean pkg extra_args = - run_clean extra_args; - List.iter - (function - | Library (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BLib cs.cs_name - | Executable (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; - BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name - | _ -> - ()) - pkg.sections - -end - -module OCamlbuildDocPlugin = struct -(* # 21 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) - - (* Create documentation using ocamlbuild .odocl files - @author Sylvain Le Gall - *) - - open OASISTypes - open OASISGettext - open OASISMessage - open OCamlbuildCommon - open BaseStandardVar - - - - let doc_build path pkg (cs, doc) argv = - let index_html = - OASISUnixPath.make - [ - path; - cs.cs_name^".docdir"; - "index.html"; - ] - in - let tgt_dir = - OASISHostPath.make - [ - build_dir argv; - OASISHostPath.of_unix path; - cs.cs_name^".docdir"; - ] - in - run_ocamlbuild [index_html] argv; - List.iter - (fun glb -> - BaseBuilt.register - BaseBuilt.BDoc - cs.cs_name - [OASISFileUtil.glob ~ctxt:!BaseContext.default - (Filename.concat tgt_dir glb)]) - ["*.html"; "*.css"] - - let doc_clean t pkg (cs, doc) argv = - run_clean argv; - BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name - -end - - -# 5558 "setup.ml" -module CustomPlugin = struct -(* # 21 "src/plugins/custom/CustomPlugin.ml" *) - - (** Generate custom configure/build/doc/test/install system - @author - *) - - open BaseEnv - open OASISGettext - open OASISTypes - - - - type t = - { - cmd_main: command_line conditional; - cmd_clean: (command_line option) conditional; - cmd_distclean: (command_line option) conditional; - } - - let run = BaseCustom.run - - let main t _ extra_args = - let cmd, args = - var_choose - ~name:(s_ "main command") - t.cmd_main - in - run cmd args extra_args - - let clean t pkg extra_args = - match var_choose t.cmd_clean with - | Some (cmd, args) -> - run cmd args extra_args - | _ -> - () - - let distclean t pkg extra_args = - match var_choose t.cmd_distclean with - | Some (cmd, args) -> - run cmd args extra_args - | _ -> - () - - module Build = - struct - let main t pkg extra_args = - main t pkg extra_args; - List.iter - (fun sct -> - let evs = - match sct with - | Library (cs, bs, lib) when var_choose bs.bs_build -> - begin - let evs, _ = - BaseBuilt.of_library - OASISHostPath.of_unix - (cs, bs, lib) - in - evs - end - | Executable (cs, bs, exec) when var_choose bs.bs_build -> - begin - let evs, _, _ = - BaseBuilt.of_executable - OASISHostPath.of_unix - (cs, bs, exec) - in - evs - end - | _ -> - [] - in - List.iter - (fun (bt, bnm, lst) -> BaseBuilt.register bt bnm lst) - evs) - pkg.sections - - let clean t pkg extra_args = - clean t pkg extra_args; - (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild - * considering moving this to BaseSetup? - *) - List.iter - (function - | Library (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BLib cs.cs_name - | Executable (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; - BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name - | _ -> - ()) - pkg.sections - - let distclean t pkg extra_args = - distclean t pkg extra_args - end - - module Test = - struct - let main t pkg (cs, test) extra_args = - try - main t pkg extra_args; - 0.0 - with Failure s -> - BaseMessage.warning - (f_ "Test '%s' fails: %s") - cs.cs_name - s; - 1.0 - - let clean t pkg (cs, test) extra_args = - clean t pkg extra_args - - let distclean t pkg (cs, test) extra_args = - distclean t pkg extra_args - end - - module Doc = - struct - let main t pkg (cs, _) extra_args = - main t pkg extra_args; - BaseBuilt.register BaseBuilt.BDoc cs.cs_name [] - - let clean t pkg (cs, _) extra_args = - clean t pkg extra_args; - BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name - - let distclean t pkg (cs, _) extra_args = - distclean t pkg extra_args - end - -end - - -# 5694 "setup.ml" -open OASISTypes;; - -let setup_t = - { - BaseSetup.configure = InternalConfigurePlugin.configure; - build = OCamlbuildPlugin.build; - test = - [ - ("test_networkd", - CustomPlugin.Test.main - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("$network_test", []))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }) - ]; - doc = []; - install = InternalInstallPlugin.install; - uninstall = InternalInstallPlugin.uninstall; - clean = [OCamlbuildPlugin.clean]; - clean_test = - [ - ("test_networkd", - CustomPlugin.Test.clean - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("$network_test", []))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }) - ]; - clean_doc = []; - distclean = []; - distclean_test = - [ - ("test_networkd", - CustomPlugin.Test.distclean - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("$network_test", []))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }) - ]; - distclean_doc = []; - package = - { - oasis_version = "0.3"; - ocaml_version = None; - findlib_version = None; - name = "xcp-networkd"; - version = "0.10.0"; - license = - OASISLicense.DEP5License - (OASISLicense.DEP5Unit - { - OASISLicense.license = "LGPL"; - excption = Some "OCaml linking"; - version = OASISLicense.Version "2.1"; - }); - license_file = None; - copyrights = []; - maintainers = []; - authors = ["Rob Hoes"]; - homepage = None; - synopsis = "XCP Network Daemon"; - description = None; - categories = []; - conf_type = (`Configure, "internal", Some "0.3"); - conf_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - build_type = (`Build, "ocamlbuild", Some "0.3"); - build_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - install_type = (`Install, "internal", Some "0.3"); - install_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - uninstall_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - clean_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - distclean_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - files_ab = []; - sections = - [ - Library - ({ - cs_name = "profiling"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "profiling"; - bs_compiled_object = Best; - bs_build_depends = []; - 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, [])]; - }, - { - lib_modules = ["Coverage"]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = None; - lib_findlib_name = None; - lib_findlib_containers = []; - }); - Library - ({ - cs_name = "networklibs"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "lib"; - bs_compiled_object = Best; - bs_build_depends = - [ - FindlibPackage ("forkexec", None); - FindlibPackage ("stdext", None); - FindlibPackage ("threads", None); - FindlibPackage ("rpclib", None); - FindlibPackage ("stdext", None); - FindlibPackage ("xcp-inventory", None); - FindlibPackage ("xcp.network", None); - FindlibPackage ("systemd", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = - [ - (OASISExpr.EBool true, - ["-Wno-unused-function"; "-g"; "-ggdb"]) - ]; - 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, [])]; - }, - { - lib_modules = - ["Network_config"; "Network_utils"; "Jsonrpc_client"]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = None; - lib_findlib_name = Some "network-libs"; - lib_findlib_containers = []; - }); - Executable - ({ - cs_name = "xcp_networkd"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "networkd"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "profiling"; - FindlibPackage ("threads", None); - FindlibPackage ("rpclib", None); - FindlibPackage ("rpclib.unix", None); - FindlibPackage ("forkexec", None); - FindlibPackage ("stdext", None); - FindlibPackage ("xcp-inventory", None); - InternalLibrary "networklibs"; - FindlibPackage ("xen-api-client", None); - FindlibPackage ("xcp", None); - FindlibPackage ("xcp.network", None); - FindlibPackage ("netlink", None); - FindlibPackage ("systemd", 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 = "networkd.ml"; }); - Executable - ({ - cs_name = "networkd_db"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "networkd_db"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "profiling"; - InternalLibrary "networklibs"; - FindlibPackage ("stdext", None); - FindlibPackage ("threads", None); - FindlibPackage ("xcp.network", 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 = "networkd_db.ml"; }); - Executable - ({ - cs_name = "network_test"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "test"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "profiling"; - FindlibPackage ("stdext", None); - FindlibPackage ("oUnit", None); - InternalLibrary "networklibs"; - FindlibPackage ("xapi-test-utils", 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 = false; exec_main_is = "network_test.ml"; }); - Test - ({ - cs_name = "test_networkd"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - test_type = (`Test, "custom", Some "0.3"); - test_command = - [(OASISExpr.EBool true, ("$network_test", []))]; - test_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - test_working_directory = Some "."; - test_run = - [ - (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); - (OASISExpr.EFlag "tests", false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tests", - OASISExpr.EFlag "tests"), - true) - ]; - test_tools = [ExternalTool "ocamlbuild"]; - }); - Executable - ({ - cs_name = "cli"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "cli"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "profiling"; - FindlibPackage ("cmdliner", None); - FindlibPackage ("stdext", None); - InternalLibrary "networklibs"; - FindlibPackage ("xcp", None); - FindlibPackage ("xcp.network", 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 = false; exec_main_is = "network_cli.ml"; }); - Executable - ({ - cs_name = "jsonrpc_dummy"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "test"; - bs_compiled_object = Best; - bs_build_depends = [InternalLibrary "networklibs"]; - 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 = false; exec_main_is = "jsonrpc_dummy.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 "y\007\213\140M(?\198\232KQps\t\171\199"; - oasis_exec = None; - oasis_setup_args = []; - setup_update = false; - };; - -let setup () = BaseSetup.setup setup_t;; - -# 6070 "setup.ml" -(* OASIS_STOP *) -let () = setup ();; diff --git a/test/jbuild b/test/jbuild new file mode 100644 index 000000000..e0b15a91e --- /dev/null +++ b/test/jbuild @@ -0,0 +1,13 @@ +(executable + ((name network_test) + (public_name network-test) + (package xcp-networkd) + (flags (:standard -bin-annot -warn-error +a-27)) + (libraries (profiling + stdext + oUnit + networklibs + xapi-test-utils) + ) + ) +) \ No newline at end of file From 80b1904dc9a08847266059e9b66734788b036334 Mon Sep 17 00:00:00 2001 From: Yarsin He Date: Thu, 7 Dec 2017 16:19:03 +0000 Subject: [PATCH 156/260] CP-26156: Port xcp-networkd to use jbuilder -- rework based on comments --- .gitignore | 13 ++----------- Makefile | 19 ++++++++++--------- cli/jbuild | 2 +- lib/jbuild | 2 +- networkd/jbuild | 2 +- networkd_db/jbuild | 2 +- test/jbuild | 11 +++++++---- 7 files changed, 23 insertions(+), 28 deletions(-) diff --git a/.gitignore b/.gitignore index 2e3f30293..a16154646 100644 --- a/.gitignore +++ b/.gitignore @@ -1,12 +1,3 @@ -*.swp -setup.bin -networkd/version.ml -xcp-networkd -xcp-networkd.1 -*.native -setup.data -setup.log -*.merlin -*.install -dist/ _build/ +*.merlin +*.install \ No newline at end of file diff --git a/Makefile b/Makefile index c20a837ab..c355d163a 100644 --- a/Makefile +++ b/Makefile @@ -2,13 +2,13 @@ BINDIR ?= /usr/bin SBINDIR ?= /usr/sbin MANDIR ?= /usr/share/man/man1 -.PHONY: build release install uninstall clean test doc reindent - -build: - jbuilder build @networkd/man @install --dev +.PHONY: release build install uninstall clean test doc reindent release: - jbuilder build @install + jbuilder build @install @networkd/man + +build: + jbuilder build @install @networkd/man --dev install: mkdir -p $(DESTDIR)$(SBINDIR) @@ -19,14 +19,15 @@ install: cp _build/default/networkd_db/networkd_db.exe $(DESTDIR)$(BINDIR)/networkd_db uninstall: - rm -f $(DESTDIR)$(SBINDIR)/xcp-networkd - rm -f $(DESTDIR)$(MANDIR)/xcp-networkd.1 - rm -f $(DESTDIR)$(SBINDIR)/networkd_db + rm -f $(DESTDIR)$(SBINDIR)/xcp-networkd + rm -f $(DESTDIR)$(MANDIR)/xcp-networkd.1 + rm -f $(DESTDIR)$(SBINDIR)/networkd_db + clean: jbuilder clean test: - _build/default/test/network_test.exe + jbuilder runtest # requires odoc doc: diff --git a/cli/jbuild b/cli/jbuild index 26650f87c..03c83b513 100644 --- a/cli/jbuild +++ b/cli/jbuild @@ -2,7 +2,7 @@ ((name network_cli) (public_name networkd-cli) (package xcp-networkd) - (flags (:standard -bin-annot -warn-error +a-6)) + (flags (:standard -bin-annot)) (libraries (profiling cmdliner stdext diff --git a/lib/jbuild b/lib/jbuild index 5163c8bb1..b22446e8a 100644 --- a/lib/jbuild +++ b/lib/jbuild @@ -2,7 +2,7 @@ (library ((name networklibs) - (flags (:standard :standard -bin-annot -warn-error +a-6-27-33-52)) + (flags (:standard :standard -bin-annot)) (libraries (forkexec threads rpclib diff --git a/networkd/jbuild b/networkd/jbuild index 8439d33da..f3fee4698 100644 --- a/networkd/jbuild +++ b/networkd/jbuild @@ -16,7 +16,7 @@ ((name networkd) (public_name xcp-networkd) (package xcp-networkd) - (flags (:standard -bin-annot -warn-error +a-33-6-9-27)) + (flags (:standard -bin-annot)) (libraries (networklibs profiling threads diff --git a/networkd_db/jbuild b/networkd_db/jbuild index 87afd99f3..6df1c7fd7 100644 --- a/networkd_db/jbuild +++ b/networkd_db/jbuild @@ -2,7 +2,7 @@ ((name networkd_db) (public_name networkd_db) (package xcp-networkd) - (flags (:standard -bin-annot -warn-error +a-27)) + (flags (:standard -bin-annot)) (libraries (profiling networklibs stdext diff --git a/test/jbuild b/test/jbuild index e0b15a91e..b32c17fd9 100644 --- a/test/jbuild +++ b/test/jbuild @@ -1,8 +1,6 @@ (executable ((name network_test) - (public_name network-test) - (package xcp-networkd) - (flags (:standard -bin-annot -warn-error +a-27)) + (flags (:standard -bin-annot)) (libraries (profiling stdext oUnit @@ -10,4 +8,9 @@ xapi-test-utils) ) ) -) \ No newline at end of file +) + +(alias + ((name runtest) + (deps (network_test.exe)) + (action (chdir ../../.. (run ${<}))))) From 03a4a95628d9f6eddae3ac5bd996eb6f8143fdd8 Mon Sep 17 00:00:00 2001 From: Yarsin He Date: Thu, 7 Dec 2017 17:14:10 +0000 Subject: [PATCH 157/260] CP-26156: Port xcp-networkd to use jbuilder -- rework++ --- xcp-networkd.opam | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) create mode 100644 xcp-networkd.opam diff --git a/xcp-networkd.opam b/xcp-networkd.opam new file mode 100644 index 000000000..f628c8034 --- /dev/null +++ b/xcp-networkd.opam @@ -0,0 +1,21 @@ +opam-version: "1" +maintainer: "jonathan.ludlam@eu.citrix.com" + +build: [ + "jbuilder" "build" "-p" name "-j" jobs +] + +build-test: ["jbuilder" "runtest" "-p" name] + +depends: [ + "jbuilder" {build} + "netlink" + "rpc" + "systemd" + "xapi-forkexecd" + "xapi-idl" + "xapi-inventory" + "xapi-libs-transitional" + "xapi-stdext" {>= "3.0.0"} + "xen-api-client" +] \ No newline at end of file From 41dfa3b1f0d2fee939487dc08994150c99002939 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Fri, 8 Dec 2017 09:31:31 +0000 Subject: [PATCH 158/260] rename package: xcp-networkd -> xapi-networkd Signed-off-by: Marcello Seri --- cli/jbuild | 2 +- networkd/jbuild | 4 ++-- networkd_db/jbuild | 2 +- xcp-networkd.opam => xapi-networkd.opam | 0 4 files changed, 4 insertions(+), 4 deletions(-) rename xcp-networkd.opam => xapi-networkd.opam (100%) diff --git a/cli/jbuild b/cli/jbuild index 03c83b513..3d807ebe1 100644 --- a/cli/jbuild +++ b/cli/jbuild @@ -1,7 +1,7 @@ (executable ((name network_cli) (public_name networkd-cli) - (package xcp-networkd) + (package xapi-networkd) (flags (:standard -bin-annot)) (libraries (profiling cmdliner diff --git a/networkd/jbuild b/networkd/jbuild index f3fee4698..b7ea51acd 100644 --- a/networkd/jbuild +++ b/networkd/jbuild @@ -14,8 +14,8 @@ (executable ((name networkd) - (public_name xcp-networkd) - (package xcp-networkd) + (public_name xapi-networkd) + (package xapi-networkd) (flags (:standard -bin-annot)) (libraries (networklibs profiling diff --git a/networkd_db/jbuild b/networkd_db/jbuild index 6df1c7fd7..063148c0f 100644 --- a/networkd_db/jbuild +++ b/networkd_db/jbuild @@ -1,7 +1,7 @@ (executable ((name networkd_db) (public_name networkd_db) - (package xcp-networkd) + (package xapi-networkd) (flags (:standard -bin-annot)) (libraries (profiling networklibs diff --git a/xcp-networkd.opam b/xapi-networkd.opam similarity index 100% rename from xcp-networkd.opam rename to xapi-networkd.opam From 350d54b90f106df522c20f3b956e1c2b4ecbd86c Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Thu, 14 Dec 2017 10:45:59 +0000 Subject: [PATCH 159/260] Port to xapi-stdext-* submodules and Xstringext -> Astring Signed-off-by: Marcello Seri --- cli/jbuild | 5 +- cli/network_cli.ml | 6 +- lib/jbuild | 11 +-- lib/network_config.ml | 38 ++++++--- lib/network_utils.ml | 122 +++++++++++++++------------ networkd/jbuild | 17 ++-- networkd/network_monitor.ml | 2 +- networkd/network_monitor_thread.ml | 17 ++-- networkd/network_server.ml | 71 +++++++++------- networkd/networkd.ml | 7 +- networkd_db/jbuild | 5 +- test/jbuild | 6 +- test/network_test_lacp_properties.ml | 6 +- test/test_jsonrpc_client.ml | 4 +- xapi-networkd.opam | 7 +- 15 files changed, 184 insertions(+), 140 deletions(-) diff --git a/cli/jbuild b/cli/jbuild index 3d807ebe1..67ec86e82 100644 --- a/cli/jbuild +++ b/cli/jbuild @@ -3,10 +3,11 @@ (public_name networkd-cli) (package xapi-networkd) (flags (:standard -bin-annot)) - (libraries (profiling + (libraries (astring cmdliner - stdext networklibs + profiling + xapi-stdext-unix xcp xcp.network) ) diff --git a/cli/network_cli.ml b/cli/network_cli.ml index 1e1a62934..682981ad9 100644 --- a/cli/network_cli.ml +++ b/cli/network_cli.ml @@ -219,11 +219,11 @@ let get_dns_cmd = let set_dns iface nameservers domains = try let ns = match nameservers with - | Some x -> List.map Unix.inet_addr_of_string (Stdext.Xstringext.String.split ',' x) + | Some x -> List.map Unix.inet_addr_of_string (Astring.String.cuts ~empty:false ~sep:"," x) | None -> [] in let d = match domains with - | Some x -> Stdext.Xstringext.String.split ',' x + | Some x -> Astring.String.cuts ~empty:false ~sep:"," x | None -> [] in Client.Interface.set_dns dbg iface ns d; @@ -316,7 +316,7 @@ let list_br_cmd = Term.info "list-br" ~doc ~man let read_config path = - let config_json = Stdext.Unixext.string_of_file path in + let config_json = Xapi_stdext_unix.Unixext.string_of_file path in config_json |> Jsonrpc.of_string |> config_t_of_rpc let config path = diff --git a/lib/jbuild b/lib/jbuild index b22446e8a..656c39780 100644 --- a/lib/jbuild +++ b/lib/jbuild @@ -3,13 +3,14 @@ (library ((name networklibs) (flags (:standard :standard -bin-annot)) - (libraries (forkexec - threads + (libraries (astring + forkexec rpclib - stdext + systemd + threads + xapi-stdext-unix xcp-inventory - xcp.network - systemd)) + xcp.network)) (wrapped false) ) ) \ No newline at end of file diff --git a/lib/network_config.ml b/lib/network_config.ml index 4c95d00e6..0c6ce5b96 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -14,28 +14,42 @@ open Network_interface -open Stdext -open Fun -open Xstringext - module D = Debug.Make(struct let name = "network_config" end) open D +(* Backport of stdext rtrim using Astring functions *) +let rtrim s = + let open Astring in + let drop = Char.Ascii.is_white in + let len = String.length s in + if len = 0 then s else + let max_idx = len - 1 in + let rec right_pos i = + if i < 0 then 0 else + if drop (String.unsafe_get s i) then right_pos (i - 1) else (i + 1) + in + let right = right_pos max_idx in + if right = len then s else String.take ~max:right s + exception Read_error exception Write_error let config_file_path = "/var/lib/xcp/networkd.db" let bridge_naming_convention (device: string) = - if String.startswith "eth" device + if Astring.String.is_prefix ~affix:"eth" device then ("xenbr" ^ (String.sub device 3 (String.length device - 3))) else ("br" ^ device) let read_management_conf () = try - let management_conf = Unixext.string_of_file ("/etc/firstboot.d/data/management.conf") in - let args = String.split '\n' (String.rtrim management_conf) in - let args = List.map (fun s -> match (String.split '=' s) with k :: [v] -> k, String.strip ((=) '\'') v | _ -> "", "") args in + let management_conf = Xapi_stdext_unix.Unixext.string_of_file ("/etc/firstboot.d/data/management.conf") in + let args = Astring.String.cuts ~empty:false ~sep:"\n" (rtrim management_conf) in + let args = List.map (fun s -> + match (Astring.String.cuts ~empty:false ~sep:"=" s) with + | k :: [v] -> k, Astring.String.trim ~drop:((=) '\'') v + | _ -> "", "" + ) args in debug "Firstboot file management.conf has: %s" (String.concat "; " (List.map (fun (k, v) -> k ^ "=" ^ v) args)); let device = List.assoc "LABEL" args in let vlan = if List.mem_assoc "VLAN" args then Some (List.assoc "VLAN" args) else None in @@ -55,12 +69,12 @@ let read_management_conf () = in let nameservers = if List.mem_assoc "DNS" args && List.assoc "DNS" args <> "" then - List.map Unix.inet_addr_of_string (String.split ',' (List.assoc "DNS" args)) + List.map Unix.inet_addr_of_string (Astring.String.cuts ~empty:false ~sep:"," (List.assoc "DNS" args)) else [] in let domains = if List.mem_assoc "DOMAIN" args && List.assoc "DOMAIN" args <> "" then - String.split ' ' (List.assoc "DOMAIN" args) + Astring.String.cuts ~empty:false ~sep:" " (List.assoc "DOMAIN" args) else [] in let dns = nameservers, domains in @@ -105,7 +119,7 @@ let read_management_conf () = let write_config config = try let config_json = config |> rpc_of_config_t |> Jsonrpc.to_string in - Unixext.write_string_to_file config_file_path config_json + Xapi_stdext_unix.Unixext.write_string_to_file config_file_path config_json with e -> error "Error while trying to write networkd configuration: %s\n%s" (Printexc.to_string e) (Printexc.get_backtrace ()); @@ -113,7 +127,7 @@ let write_config config = let read_config () = try - let config_json = Unixext.string_of_file config_file_path in + let config_json = Xapi_stdext_unix.Unixext.string_of_file config_file_path in config_json |> Jsonrpc.of_string |> config_t_of_rpc with | Unix.Unix_error (Unix.ENOENT, _, file) -> diff --git a/lib/network_utils.ml b/lib/network_utils.ml index d4ad079d3..6abe7105e 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -12,11 +12,23 @@ * GNU Lesser General Public License for more details. *) -open Stdext -open Listext -open Xstringext -open Pervasiveext -open Fun +open Xapi_stdext_std.Listext +open Xapi_stdext_pervasives.Pervasiveext + +(* Backport of stdext rtrim using Astring functions *) +let rtrim s = + let open Astring in + let drop = Char.Ascii.is_white in + let len = String.length s in + if len = 0 then s else + let max_idx = len - 1 in + let rec right_pos i = + if i < 0 then 0 else + if drop (String.unsafe_get s i) then right_pos (i - 1) else (i + 1) + in + let right = right_pos max_idx in + if right = len then s else String.take ~max:right s + open Network_interface module D = Debug.Make(struct let name = "network_utils" end) @@ -93,7 +105,7 @@ module Sysfs = struct let get_driver_version driver () = try - Some (String.strip String.isspace (Unixext.string_of_file ("/sys/bus/pci/drivers/" ^ driver ^ "/module/version"))) + Some (Astring.String.trim (Xapi_stdext_unix.Unixext.string_of_file ("/sys/bus/pci/drivers/" ^ driver ^ "/module/version"))) with _ -> warn "Failed to obtain driver version from sysfs"; None @@ -128,7 +140,7 @@ module Sysfs = struct let devpath = getpath name "device" in let driver_link = Unix.readlink (devpath ^ "/driver") in (* filter out symlinks under device/driver which look like /../../../devices/xen-backend/vif- *) - not(List.mem "xen-backend" (String.split '/' driver_link)) + not(List.mem "xen-backend" (Astring.String.cuts ~empty:false ~sep:"/" driver_link)) with _ -> false let get_carrier name = @@ -140,7 +152,7 @@ module Sysfs = struct let get_pcibuspath name = try let devpath = Unix.readlink (getpath name "device") in - List.hd (List.rev (String.split '/' devpath)) + List.hd (List.rev (Astring.String.cuts ~empty:false ~sep:"/" devpath)) with exn -> "N/A" let get_pci_ids name = @@ -159,10 +171,9 @@ module Sysfs = struct try let symlink = getpath dev "device/driver" in let target = Unix.readlink symlink in - try - let slash = String.index target '/' in - Some (String.sub_to_end target (slash + 1)) - with Not_found -> + match Astring.String.cut ~sep:"/" target with + | Some (prefix, suffix) -> Some prefix + | None -> debug "target %s of symbolic link %s does not contain slash" target symlink; None with _ -> @@ -228,7 +239,7 @@ module Ip = struct let find output attr = info "Looking for %s in [%s]" attr output; - let args = String.split_f String.isspace output in + let args = Astring.String.fields ~empty:false output in let indices = (List.position (fun s -> s = attr) args) in info "Found at [ %s ]" (String.concat ", " (List.map string_of_int indices)); List.map (fun i -> List.nth args (succ i)) indices @@ -238,7 +249,7 @@ info "Found at [ %s ]" (String.concat ", " (List.map string_of_int indices)); let i = String.index output '<' in let j = String.index output '>' in let flags = String.sub output (i + 1) (j - i - 1) in - String.split ',' flags + Astring.String.cuts ~empty:false ~sep:"," flags let is_up dev = try @@ -293,17 +304,17 @@ info "Found at [ %s ]" (String.concat ", " (List.map string_of_int indices)); with _ -> () let split_addr addr = - try - let i = String.index addr '/' in - let ip = Unix.inet_addr_of_string (String.sub addr 0 i) in - let prefixlen = int_of_string (String.sub_to_end addr (i + 1)) in + match Astring.String.cut ~sep:"/" addr with + | Some (ipstr, prefixlenstr) -> + let ip = Unix.inet_addr_of_string ipstr in + let prefixlen = int_of_string prefixlenstr in Some (ip, prefixlen) - with Not_found -> None + | None -> None (* see http://en.wikipedia.org/wiki/IPv6_address#Modified_EUI-64 *) let get_ipv6_interface_id dev = let mac = get_mac dev in - let bytes = List.map (fun byte -> int_of_string ("0x" ^ byte)) (String.split ':' mac) in + let bytes = List.map (fun byte -> int_of_string ("0x" ^ byte)) (Astring.String.cuts ~empty:false ~sep:":" mac) in let rec modified_bytes ac i = function | [] -> ac @@ -426,7 +437,7 @@ module Linux_bonding = struct let is_bond_device name = try - List.exists ((=) name) (String.split ' ' (Sysfs.read_one_line bonding_masters)) + List.exists ((=) name) (Astring.String.cuts ~empty:false ~sep:" " (Sysfs.read_one_line bonding_masters)) with _ -> false (** Ensures that a bond master device exists in the kernel. *) @@ -466,7 +477,7 @@ module Linux_bonding = struct if slaves = "" then [] else - String.split ' ' slaves + Astring.String.cuts ~empty:false ~sep:" " slaves let add_bond_slaves master slaves = List.iter (fun slave -> @@ -519,7 +530,7 @@ module Linux_bonding = struct let master_path = Unix.readlink master_symlink in let slaves_path = Filename.concat master_symlink "bonding/slaves" in Unix.access slaves_path [ Unix.F_OK ]; - Some (List.hd (List.rev (String.split '/' master_path))) + Some (List.hd (List.rev (Astring.String.cuts ~empty:false ~sep:"/" master_path))) with _ -> None let get_bond_active_slave master = @@ -537,7 +548,7 @@ module Linux_bonding = struct try let bond_prop = Sysfs.read_one_line (Sysfs.getpath master ("bonding/" ^ prop)) in if prop = "mode" then - Some (prop, List.hd (String.split ' ' bond_prop)) + Some (prop, List.hd (Astring.String.cuts ~empty:false ~sep:" " bond_prop)) else Some (prop, bond_prop) with _ -> debug "Failed to get property \"%s\" on bond %s" prop master; @@ -602,11 +613,11 @@ module Dhclient = struct let read_conf_file ?(ipv6=false) interface = let file = conf_file ~ipv6 interface in - try Some (Unixext.string_of_file file) with _ -> None + try Some (Xapi_stdext_unix.Unixext.string_of_file file) with _ -> None let write_conf_file ?(ipv6=false) interface options = let conf = generate_conf ~ipv6 interface options in - Unixext.write_string_to_file (conf_file ~ipv6 interface) conf + Xapi_stdext_unix.Unixext.write_string_to_file (conf_file ~ipv6 interface) conf let start ?(ipv6=false) interface options = (* If we have a gateway interface, pass it to dhclient-script via -e *) @@ -664,10 +675,10 @@ module Fcoe = struct let get_capabilities name = try let output = call ["--xapi"; name; "capable"] in - if String.has_substr output "True" then ["fcoe"] else [] - with _ -> - debug "Failed to get fcoe support status on device %s" name; - [] + if Astring.String.is_infix ~affix:"True" output then ["fcoe"] else [] + with _ -> + debug "Failed to get fcoe support status on device %s" name; + [] end module Sysctl = struct @@ -690,8 +701,8 @@ end module Proc = struct let get_bond_slave_info name key = try - let raw = Unixext.string_of_file (bonding_dir ^ name) in - let lines = String.split '\n' raw in + let raw = Xapi_stdext_unix.Unixext.string_of_file (bonding_dir ^ name) in + let lines = Astring.String.cuts ~empty:false ~sep:"\n" raw in let check_lines lines = let rec loop current acc = function | [] -> acc @@ -699,11 +710,11 @@ module Proc = struct try Scanf.sscanf line "%s@: %s@\n" (fun k v -> if k = "Slave Interface" then begin - let interface = Some (String.strip String.isspace v) in + let interface = Some (Astring.String.trim v) in loop interface acc tail end else if k = key then match current with - | Some interface -> loop current ((interface, String.strip String.isspace v) :: acc) tail + | Some interface -> loop current ((interface, Astring.String.trim v) :: acc) tail | None -> loop current acc tail else loop current acc tail @@ -727,7 +738,7 @@ module Proc = struct let get_vlans () = try - Unixext.file_lines_fold (fun vlans line -> + Xapi_stdext_unix.Unixext.file_lines_fold (fun vlans line -> try let x = Scanf.sscanf line "%s | %d | %s" (fun device vlan parent -> device, vlan, parent) in x :: vlans @@ -750,6 +761,7 @@ module Ovs = struct val ofctl : ?log:bool -> string list -> string val appctl : ?log:bool -> string list -> string end = struct + open Xapi_stdext_threads let s = Semaphore.create 5 let vsctl ?(log=false) args = Semaphore.execute s (fun () -> @@ -769,12 +781,12 @@ module Ovs = struct let port_to_interfaces name = try let raw = vsctl ["get"; "port"; name; "interfaces"] in - let raw = String.rtrim raw in + let raw = rtrim raw in if raw <> "[]" then - let raw_list = (String.split ',' (String.sub raw 1 (String.length raw - 2))) in - let uuids = List.map (String.strip String.isspace) raw_list in + let raw_list = (Astring.String.cuts ~empty:false ~sep:"," (String.sub raw 1 (String.length raw - 2))) in + let uuids = List.map (Astring.String.trim) raw_list in List.map (fun uuid -> - let raw = String.rtrim (vsctl ["get"; "interface"; uuid; "name"]) in + let raw = rtrim (vsctl ["get"; "interface"; uuid; "name"]) in String.sub raw 1 (String.length raw - 2)) uuids else [] @@ -782,10 +794,10 @@ module Ovs = struct let bridge_to_ports name = try - let ports = String.rtrim (vsctl ["list-ports"; name]) in + let ports = rtrim (vsctl ["list-ports"; name]) in let ports' = if ports <> "" then - String.split '\n' ports + Astring.String.cuts ~empty:false ~sep:"\n" ports else [] in @@ -794,17 +806,17 @@ module Ovs = struct let bridge_to_interfaces name = try - let ifaces = String.rtrim (vsctl ["list-ifaces"; name]) in + let ifaces = rtrim (vsctl ["list-ifaces"; name]) in if ifaces <> "" then - String.split '\n' ifaces + Astring.String.cuts ~empty:false ~sep:"\n" ifaces else [] with _ -> [] let bridge_to_vlan name = try - let parent = vsctl ["br-to-parent"; name] |> String.rtrim in - let vlan = vsctl ["br-to-vlan"; name] |> String.rtrim |> int_of_string in + let parent = vsctl ["br-to-parent"; name] |> rtrim in + let vlan = vsctl ["br-to-vlan"; name] |> rtrim |> int_of_string in Some (parent, vlan) with e -> debug "bridge_to_vlan: %s" (Printexc.to_string e); @@ -818,7 +830,7 @@ module Ovs = struct let get_bond_link_status name = try let raw = appctl ["bond/show"; name] in - let lines = String.split '\n' raw in + let lines = Astring.String.cuts ~empty:false ~sep:"\n" raw in List.fold_left (fun (slaves, active_slave) line -> let slaves = try @@ -843,7 +855,7 @@ module Ovs = struct let get_bond_mode name = try - let output = String.rtrim (vsctl ["get"; "port"; name; "bond_mode"]) in + let output = rtrim (vsctl ["get"; "port"; name; "bond_mode"]) in if output <> "[]" then Some output else None with _ -> None @@ -894,17 +906,17 @@ module Ovs = struct let vlans_with_uuid = let raw = vsctl ["--bare"; "-f"; "table"; "--"; "--columns=name,_uuid"; "find"; "port"; "fake_bridge=true"] in if raw <> "" then - let lines = String.split '\n' (String.rtrim raw) in + let lines = Astring.String.cuts ~empty:false ~sep:"\n" (rtrim raw) in List.map (fun line -> Scanf.sscanf line "%s %s" (fun a b-> a, b)) lines else [] in let bridge_ports = let raw = vsctl ["get"; "bridge"; name; "ports"] in - let raw = String.rtrim raw in + let raw = rtrim raw in if raw <> "[]" then - let raw_list = (String.split ',' (String.sub raw 1 (String.length raw - 2))) in - List.map (String.strip String.isspace) raw_list + let raw_list = (Astring.String.cuts ~empty:false ~sep:"," (String.sub raw 1 (String.length raw - 2))) in + List.map Astring.String.trim raw_list else [] in @@ -923,7 +935,7 @@ module Ovs = struct let get_mcast_snooping_enable ~name = try vsctl ~log:true ["--"; "get"; "bridge"; name; "mcast_snooping_enable"] - |> String.rtrim + |> rtrim |> bool_of_string with _ -> false @@ -931,7 +943,7 @@ module Ovs = struct try let vvifs = get_bridge_vlan_vifs name in let bvifs = bridge_to_interfaces name in - let bvifs' = List.filter(fun vif -> Xstringext.String.startswith "vif" vif) bvifs in + let bvifs' = List.filter (fun vif -> Astring.String.is_prefix ~affix:"vif" vif) bvifs in (* The vifs may be large. However considering current XS limit of 1000VM*7NIC/VM + 800VLANs, the buffer of CLI should be sufficient for lots of vifxxxx.xx *) fork_script !inject_igmp_query_script (["--no-check-snooping-toggle"; "--max-resp-time"; !igmp_query_maxresp_time] @ bvifs' @ vvifs) with _ -> () @@ -1006,9 +1018,9 @@ module Ovs = struct vsctl ~log:true ["--"; "--if-exists"; "del-br"; name] let list_bridges () = - let bridges = String.rtrim (vsctl ["list-br"]) in + let bridges = rtrim (vsctl ["list-br"]) in if bridges <> "" then - String.split '\n' bridges + Astring.String.cuts ~empty:false ~sep:"\n" bridges else [] diff --git a/networkd/jbuild b/networkd/jbuild index b7ea51acd..0194f7d10 100644 --- a/networkd/jbuild +++ b/networkd/jbuild @@ -17,19 +17,22 @@ (public_name xapi-networkd) (package xapi-networkd) (flags (:standard -bin-annot)) - (libraries (networklibs + (libraries (forkexec + netlink + networklibs profiling - threads rpclib rpclib.unix - forkexec - stdext + systemd + threads + xapi-stdext-monadic + xapi-stdext-pervasives + xapi-stdext-threads + xapi-stdext-unix xcp-inventory - xen-api-client xcp xcp.network - netlink - systemd) + xen-api-client) ) ) ) diff --git a/networkd/network_monitor.ml b/networkd/network_monitor.ml index 0e485be5b..23e1b9a66 100644 --- a/networkd/network_monitor.ml +++ b/networkd/network_monitor.ml @@ -20,4 +20,4 @@ let write_stats stats = let checksum = payload |> Digest.string |> Digest.to_hex in let length = String.length payload in let data = Printf.sprintf "%s%s%08x%s" magic checksum length payload in - Stdext.Unixext.write_string_to_file stats_file (data) + Xapi_stdext_unix.Unixext.write_string_to_file stats_file (data) diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index 13d9002bf..83cf1a71a 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -14,10 +14,9 @@ open Network_utils -open Stdext -open Xstringext -open Listext -open Threadext +open Xapi_stdext_pervasives +open Xapi_stdext_std.Listext +open Xapi_stdext_threads.Threadext module D = Debug.Make(struct let name = "network_monitor_thread" end) open D @@ -56,7 +55,7 @@ let send_bond_change_alert dev interfaces message = let check_for_changes ~(dev : string) ~(stat : Network_monitor.iface_stats) = let open Network_monitor in - match String.startswith "vif" dev with true -> () | false -> + match Astring.String.is_prefix ~affix:"vif" dev with true -> () | false -> if stat.nb_links > 1 then ( (* It is a bond. *) if Hashtbl.mem bonds_status dev then ( (* Seen before. *) let nb_links_old, links_up_old = Hashtbl.find bonds_status dev in @@ -105,10 +104,10 @@ let get_link_stats () = let links = Link.cache_to_list cache in let links = let is_whitelisted name = - List.exists (fun s -> String.startswith s name) !monitor_whitelist + List.exists (fun s -> Astring.String.is_prefix ~affix:s name) !monitor_whitelist in let is_vlan name = - String.startswith "eth" name && String.contains name '.' + Astring.String.is_prefix ~affix:"eth" name && String.contains name '.' in List.map (fun link -> (standardise_name (Link.get_name link)), link @@ -175,7 +174,7 @@ let rec monitor dbg () = in let add_other_stats bonds devs = List.map (fun (dev, stat) -> - if not (String.startswith "vif" dev) then begin + if not (Astring.String.is_prefix ~affix:"vif" dev) then begin let open Network_server.Bridge in let bond_slaves = if List.mem_assoc dev bonds then @@ -293,7 +292,7 @@ let ip_watcher () = let rec loop () = let line = input_line in_channel in (* Do not send events for link-local IPv6 addresses, and removed IPs *) - if String.has_substr line "inet" && not (String.has_substr line "inet6 fe80") then begin + if Astring.String.is_infix ~affix:"inet" line && not (Astring.String.is_infix ~affix:"inet6 fe80" line) then begin (* Ignore changes for the next second, since they usually come in bursts, * and signal only once. *) Thread.delay 1.; diff --git a/networkd/network_server.ml b/networkd/network_server.ml index ed7405f6a..b48f694e0 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -15,9 +15,21 @@ open Network_utils open Network_interface -(*open Fun*) -open Stdext.Xstringext -open Stdext.Listext +open Xapi_stdext_std.Listext + +(* Backport of stdext rtrim using Astring functions *) +let rtrim s = + let open Astring in + let drop = Char.Ascii.is_white in + let len = String.length s in + if len = 0 then s else + let max_idx = len - 1 in + let rec right_pos i = + if i < 0 then 0 else + if drop (String.unsafe_get s i) then right_pos (i - 1) else (i + 1) + in + let right = right_pos max_idx in + if right = len then s else String.take ~max:right s module D = Debug.Make(struct let name = "network_server" end) open D @@ -102,7 +114,7 @@ let set_dns_interface _ dbg ~name = (* Returns `true` if vs1 is older than vs2 *) let is_older_version vs1 vs2 () = try - let list_of_version vs = List.map int_of_string (String.split '.' vs) in + let list_of_version vs = List.map int_of_string (Astring.String.cuts ~empty:false ~sep:"." vs) in let rec loop vs1' vs2' = match vs1', vs2' with | [], _ | _, [] -> false @@ -173,7 +185,8 @@ module Interface = struct Ip.flush_ip_addr name end | DHCP4 -> - let gateway = Stdext.Opt.default [] (Stdext.Opt.map (fun n -> [`gateway n]) !config.gateway_interface) in + let open Xapi_stdext_monadic in + let gateway = Opt.default [] (Opt.map (fun n -> [`gateway n]) !config.gateway_interface) in let dns = if !config.dns_interface = None || !config.dns_interface = Some name then begin debug "%s is the DNS interface" name; @@ -203,8 +216,8 @@ module Interface = struct Debug.with_thread_associated dbg (fun () -> let output = Ip.route_show ~version:Ip.V4 name in try - let line = List.find (fun s -> String.startswith "default via" s) (String.split '\n' output) in - let addr = List.nth (String.split ' ' line) 2 in + let line = List.find (fun s -> Astring.String.is_prefix ~affix:"default via" s) (Astring.String.cuts ~empty:false ~sep:"\n" output) in + let addr = List.nth (Astring.String.cuts ~empty:false ~sep:" " line) 2 in Some (Unix.inet_addr_of_string addr) with Not_found -> None ) () @@ -281,8 +294,8 @@ module Interface = struct Debug.with_thread_associated dbg (fun () -> let output = Ip.route_show ~version:Ip.V6 name in try - let line = List.find (fun s -> String.startswith "default via" s) (String.split '\n' output) in - let addr = List.nth (String.split ' ' line) 2 in + let line = List.find (fun s -> Astring.String.is_prefix ~affix:"default via" s) (Astring.String.cuts ~empty:false ~sep:"\n" output) in + let addr = List.nth (Astring.String.cuts ~empty:false ~sep:" " line) 2 in Some (Unix.inet_addr_of_string addr) with Not_found -> None ) () @@ -308,12 +321,12 @@ module Interface = struct let get_dns _ dbg ~name = Debug.with_thread_associated dbg (fun () -> - let nameservers, domains = Stdext.Unixext.file_lines_fold (fun (nameservers, domains) line -> - if String.startswith "nameserver" line then - let server = List.nth (String.split_f String.isspace line) 1 in + let nameservers, domains = Xapi_stdext_unix.Unixext.file_lines_fold (fun (nameservers, domains) line -> + if Astring.String.is_prefix ~affix:"nameserver" line then + let server = List.nth (Astring.String.fields ~empty:false line) 1 in (Unix.inet_addr_of_string server) :: nameservers, domains - else if String.startswith "search" line then - let domains = List.tl (String.split_f String.isspace line) in + else if Astring.String.is_prefix ~affix:"search" line then + let domains = List.tl (Astring.String.fields ~empty:false line) in nameservers, domains else nameservers, domains @@ -332,7 +345,7 @@ module Interface = struct let domains' = if domains <> [] then ["search " ^ (String.concat " " domains)] else [] in let nameservers' = List.map (fun ip -> "nameserver " ^ (Unix.string_of_inet_addr ip)) nameservers in let lines = domains' @ nameservers' in - Stdext.Unixext.write_string_to_file resolv_conf ((String.concat "\n" lines) ^ "\n") + Xapi_stdext_unix.Unixext.write_string_to_file resolv_conf ((String.concat "\n" lines) ^ "\n") end else debug "%s is NOT the DNS interface" name ) () @@ -480,7 +493,7 @@ module Bridge = struct let determine_backend () = try - let backend = String.strip String.isspace (Stdext.Unixext.string_of_file !network_conf) in + let backend = Astring.String.trim (Xapi_stdext_unix.Unixext.string_of_file !network_conf) in match backend with | "openvswitch" | "vswitch" -> backend_kind := Openvswitch | "bridge" -> backend_kind := Bridge @@ -510,7 +523,7 @@ module Bridge = struct | Openvswitch -> let bridges = let raw = Ovs.vsctl ["--bare"; "-f"; "table"; "--"; "--columns=name"; "find"; "port"; "fake_bridge=true"; "tag=" ^ (string_of_int vlan)] in - if raw <> "" then String.split '\n' (String.rtrim raw) else [] + if raw <> "" then Astring.String.cuts ~empty:false ~sep:"\n" (rtrim raw) else [] in let existing_bridges = List.filter ( fun bridge -> @@ -554,7 +567,7 @@ module Bridge = struct | None -> "" | Some (parent, vlan) -> Printf.sprintf " (VLAN %d on bridge %s)" vlan parent ); - Stdext.Opt.iter (destroy_existing_vlan_bridge name) vlan; + Xapi_stdext_monadic.Opt.iter (destroy_existing_vlan_bridge name) vlan; update_config name {(get_config name) with vlan; bridge_mac=mac; igmp_snooping; other_config}; begin match !backend_kind with | Openvswitch -> @@ -607,13 +620,13 @@ module Bridge = struct ignore (Brctl.create_bridge name); Brctl.set_forwarding_delay name 0; Sysfs.set_multicast_snooping name false; - Stdext.Opt.iter (Ip.set_mac name) mac; + Xapi_stdext_monadic.Opt.iter (Ip.set_mac name) mac; match vlan with | None -> () | Some (parent, vlan) -> let bridge_interfaces = Sysfs.bridge_to_interfaces name in let parent_bridge_interface = List.hd (List.filter (fun n -> - String.startswith "eth" n || String.startswith "bond" n + Astring.String.is_prefix ~affix:"eth" n || Astring.String.is_prefix ~affix:"bond" n ) (Sysfs.bridge_to_interfaces parent)) in let parent_interface = if need_enic_workaround () then begin @@ -636,7 +649,7 @@ module Bridge = struct ) (Proc.get_vlans ()); (* Robustness enhancement: ensure there are no other VLANs in the bridge *) let current_interfaces = List.filter (fun n -> - String.startswith "eth" n || String.startswith "bond" n + Astring.String.is_prefix ~affix:"eth" n || Astring.String.is_prefix ~affix:"bond" n ) bridge_interfaces in debug "Removing these non-VIF interfaces found on the bridge: %s" (String.concat ", " current_interfaces); @@ -674,12 +687,12 @@ module Bridge = struct let ifs = Sysfs.bridge_to_interfaces name in let vlans_on_this_parent = let interfaces = List.filter (fun n -> - String.startswith "eth" n || String.startswith "bond" n + Astring.String.is_prefix ~affix:"eth" n || Astring.String.is_prefix ~affix:"bond" n ) ifs in match interfaces with | [] -> [] | interface :: _ -> - List.filter (String.startswith (interface ^ ".")) (Sysfs.list ()) + List.filter (Astring.String.is_prefix ~affix:(interface ^ ".")) (Sysfs.list ()) in if vlans_on_this_parent = [] || force then begin debug "Destroying bridge %s" name; @@ -690,7 +703,7 @@ module Bridge = struct Interface.bring_down () dbg ~name:dev; if Linux_bonding.is_bond_device dev then Linux_bonding.remove_bond_master dev; - if (String.startswith "eth" dev || String.startswith "bond" dev) && String.contains dev '.' then begin + if (Astring.String.is_prefix ~affix:"eth" dev || Astring.String.is_prefix ~affix:"bond" dev) && String.contains dev '.' then begin ignore (Ip.destroy_vlan dev); let n = String.length dev in if String.sub dev (n - 2) 2 = ".0" && need_enic_workaround () then @@ -776,7 +789,7 @@ module Bridge = struct let active = let ab = List.mem_assoc "mode" bond_props && - String.startswith "active-backup" (List.assoc "mode" bond_props) + Astring.String.is_prefix ~affix:"active-backup" (List.assoc "mode" bond_props) in ab && (active_slave = Some slave) || (not ab) && up @@ -1034,12 +1047,12 @@ let on_startup () = (* Remove DNSDEV and GATEWAYDEV from Centos networking file, because the interfere * with this daemon. *) try - let file = String.rtrim (Stdext.Unixext.string_of_file "/etc/sysconfig/network") in - let args = String.split '\n' file in - let args = List.map (fun s -> match (String.split '=' s) with k :: [v] -> k, v | _ -> "", "") args in + let file = rtrim (Xapi_stdext_unix.Unixext.string_of_file "/etc/sysconfig/network") in + let args = Astring.String.cuts ~empty:false ~sep:"\n" file in + let args = List.map (fun s -> match (Astring.String.cuts ~empty:false ~sep:"=" s) with k :: [v] -> k, v | _ -> "", "") args in let args = List.filter (fun (k, v) -> k <> "DNSDEV" && k <> "GATEWAYDEV") args in let s = String.concat "\n" (List.map (fun (k, v) -> k ^ "=" ^ v) args) ^ "\n" in - Stdext.Unixext.write_string_to_file "/etc/sysconfig/network" s + Xapi_stdext_unix.Unixext.write_string_to_file "/etc/sysconfig/network" s with _ -> () in try diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 9a57a1e11..5aed37376 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -12,11 +12,8 @@ * GNU Lesser General Public License for more details. *) -open Stdext -open Pervasiveext -open Fun +open Xapi_stdext_pervasives.Pervasiveext open Network_utils -open Xstringext module D = Debug.Make(struct let name = "networkd" end) open D @@ -57,7 +54,7 @@ let resources = [ ] let options = [ - "monitor_whitelist", Arg.String (fun x -> Network_monitor_thread.monitor_whitelist := String.split ',' x), (fun () -> String.concat "," !Network_monitor_thread.monitor_whitelist), "List of prefixes of interface names that are to be monitored"; + "monitor_whitelist", Arg.String (fun x -> Network_monitor_thread.monitor_whitelist := Astring.String.cuts ~empty:false ~sep:"," x), (fun () -> String.concat "," !Network_monitor_thread.monitor_whitelist), "List of prefixes of interface names that are to be monitored"; "mac-table-size", Arg.Set_int Network_utils.mac_table_size, (fun () -> string_of_int !Network_utils.mac_table_size), "Default value for the mac-table-size openvswitch parameter (see ovs-vswitchd.conf.db.5)"; "enic-workaround-until-version", Arg.Set_string Network_server.enic_workaround_until_version, (fun () -> !Network_server.enic_workaround_until_version), "The version till enic driver workaround will be applied or the version set to an empty string for not applying the workaround."; "pvs-proxy-socket", Arg.Set_string Network_server.PVS_proxy.path, (fun () -> !Network_server.PVS_proxy.path), "Path to the Unix domain socket for the PVS-proxy daemon"; diff --git a/networkd_db/jbuild b/networkd_db/jbuild index 063148c0f..e6c23c97a 100644 --- a/networkd_db/jbuild +++ b/networkd_db/jbuild @@ -3,9 +3,8 @@ (public_name networkd_db) (package xapi-networkd) (flags (:standard -bin-annot)) - (libraries (profiling - networklibs - stdext + (libraries (networklibs + profiling threads xcp.network) ) diff --git a/test/jbuild b/test/jbuild index b32c17fd9..60714966f 100644 --- a/test/jbuild +++ b/test/jbuild @@ -1,10 +1,10 @@ (executable ((name network_test) (flags (:standard -bin-annot)) - (libraries (profiling - stdext - oUnit + (libraries (astring networklibs + oUnit + profiling xapi-test-utils) ) ) diff --git a/test/network_test_lacp_properties.ml b/test/network_test_lacp_properties.ml index a2e7134da..cf5016ad5 100644 --- a/test/network_test_lacp_properties.ml +++ b/test/network_test_lacp_properties.ml @@ -90,7 +90,7 @@ let test_lacp_aggregation_key_vsctl arg () = skip_if true "Unimplemented" ; print_endline answer ; assert_bool "lacp_aggregation_key is passed to ovs-vsctl command" (List.exists - (fun s -> (Stdext.Xstringext.String.(strip isspace s) == answer)) + (fun s -> (Astring.String.trim s) == answer) !OVS_Cli_test.vsctl_output) (* Test case for bond_create with default lacp-{time,aggregation-key} settings. @@ -114,8 +114,8 @@ let test_lacp_defaults_bond_create () = List.iter (fun arg -> assert_bool "key=value argument pairs can't have missing values" - (let open Stdext.Xstringext.String in - arg |> strip isspace |> endswith "=" |> not)) + (let open Astring.String in + arg |> trim |> is_suffix ~affix:"=" |> not)) !OVS_Cli_test.vsctl_output let suite = diff --git a/test/test_jsonrpc_client.ml b/test/test_jsonrpc_client.ml index 2aeb4656f..fa7452ccc 100644 --- a/test/test_jsonrpc_client.ml +++ b/test/test_jsonrpc_client.ml @@ -14,7 +14,7 @@ open OUnit open Test_highlevel -open Stdext.Either +open Xapi_stdext_monadic.Either let dir = Filename.concat "test" "jsonrpc_files" @@ -24,7 +24,7 @@ let jsonrpc_printer : Rpc.t Test_printers.printer = module Input_json_object = Generic.Make (struct module Io = struct type input_t = string - type output_t = (exn, Rpc.t) Stdext.Either.t + type output_t = (exn, Rpc.t) Xapi_stdext_monadic.Either.t let string_of_input_t = Test_printers.string let string_of_output_t = Test_printers.(either exn jsonrpc_printer) end diff --git a/xapi-networkd.opam b/xapi-networkd.opam index f628c8034..33b3114f7 100644 --- a/xapi-networkd.opam +++ b/xapi-networkd.opam @@ -9,6 +9,7 @@ build-test: ["jbuilder" "runtest" "-p" name] depends: [ "jbuilder" {build} + "astring" "netlink" "rpc" "systemd" @@ -16,6 +17,10 @@ depends: [ "xapi-idl" "xapi-inventory" "xapi-libs-transitional" - "xapi-stdext" {>= "3.0.0"} + "xapi-stdext-monadic" + "xapi-stdext-pervasives" + "xapi-stdext-std" + "xapi-stdext-threads" + "xapi-stdext-unix" "xen-api-client" ] \ No newline at end of file From be760a2081039d686a6ec70523df180c42213e1c Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Thu, 14 Dec 2017 11:36:55 +0000 Subject: [PATCH 160/260] Be explicit in the use of Xapi_stdext_pervasives.Pervasiveext Signed-off-by: Marcello Seri --- lib/network_utils.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 6abe7105e..f2a113430 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -13,7 +13,7 @@ *) open Xapi_stdext_std.Listext -open Xapi_stdext_pervasives.Pervasiveext +open Xapi_stdext_pervasives (* Backport of stdext rtrim using Astring functions *) let rtrim s = @@ -116,7 +116,7 @@ module Sysfs = struct let read_one_line file = try let inchan = open_in file in - finally + Pervasiveext.finally (fun () -> input_line inchan) (fun () -> close_in inchan) with @@ -273,7 +273,7 @@ info "Found at [ %s ]" (String.concat ", " (List.map string_of_int indices)); let with_links_down devs f = let up_links = List.filter (fun dev -> is_up dev) devs in List.iter (fun dev -> link_set dev ["down"]) up_links; - finally + Pervasiveext.finally f (fun () -> List.iter link_set_up up_links) @@ -515,7 +515,7 @@ module Linux_bonding = struct let slaves = get_bond_slaves master in Ip.with_links_down slaves (fun () -> remove_bond_slaves master slaves; - finally + Pervasiveext.finally f (fun () -> add_bond_slaves master slaves) ) From 5e03e6ba7beba4da840973cf0bdadf87a7d168d0 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Thu, 14 Dec 2017 11:40:07 +0000 Subject: [PATCH 161/260] Be more explicit in the use of Xapi_stdext_std.Listext Signed-off-by: Marcello Seri --- lib/network_utils.ml | 15 +++++++-------- networkd/network_monitor_thread.ml | 3 +-- networkd/network_server.ml | 16 +++++++--------- 3 files changed, 15 insertions(+), 19 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index f2a113430..db26457e1 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -12,7 +12,6 @@ * GNU Lesser General Public License for more details. *) -open Xapi_stdext_std.Listext open Xapi_stdext_pervasives (* Backport of stdext rtrim using Astring functions *) @@ -240,7 +239,7 @@ module Ip = struct let find output attr = info "Looking for %s in [%s]" attr output; let args = Astring.String.fields ~empty:false output in - let indices = (List.position (fun s -> s = attr) args) in + let indices = (Xapi_stdext_std.Listext.List.position (fun s -> s = attr) args) in info "Found at [ %s ]" (String.concat ", " (List.map string_of_int indices)); List.map (fun i -> List.nth args (succ i)) indices @@ -349,11 +348,11 @@ info "Found at [ %s ]" (String.concat ", " (List.map string_of_int indices)); let get_ipv4 dev = let addrs = addr dev "inet" in - List.filter_map split_addr addrs + Xapi_stdext_std.Listext.List.filter_map split_addr addrs let get_ipv6 dev = let addrs = addr dev "inet6" in - List.filter_map split_addr addrs + Xapi_stdext_std.Listext.List.filter_map split_addr addrs let set_ip_addr dev (ip, prefixlen) = let addr = Printf.sprintf "%s/%d" (Unix.string_of_inet_addr ip) prefixlen in @@ -500,8 +499,8 @@ module Linux_bonding = struct let set_bond_slaves master slaves = if is_bond_device master then let current_slaves = get_bond_slaves master in - let slaves_to_remove = List.set_difference current_slaves slaves in - let slaves_to_add = List.set_difference slaves current_slaves in + let slaves_to_remove = Xapi_stdext_std.Listext.List.set_difference current_slaves slaves in + let slaves_to_add = Xapi_stdext_std.Listext.List.set_difference slaves current_slaves in Ip.with_links_down (slaves_to_add @ slaves_to_remove) (fun () -> remove_bond_slaves master slaves_to_remove; add_bond_slaves master slaves_to_add @@ -554,7 +553,7 @@ module Linux_bonding = struct debug "Failed to get property \"%s\" on bond %s" prop master; None in - List.filter_map get_prop known_props + Xapi_stdext_std.Listext.List.filter_map get_prop known_props end else begin debug "Bond %s does not exist; cannot get properties" master; [] @@ -1087,7 +1086,7 @@ module Ovs = struct and per_iface_args = List.flatten (List.map get_prop ["lacp-aggregation-key", "other-config:lacp-aggregation-key"; "lacp-actor-key", "other-config:lacp-actor-key";]) - and other_args = List.filter_map (fun (k, v) -> + and other_args = Xapi_stdext_std.Listext.List.filter_map (fun (k, v) -> if List.mem k known_props then None else Some (Printf.sprintf "other-config:\"%s\"=\"%s\"" (String.escaped ("bond-" ^ k)) (String.escaped v)) diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index 83cf1a71a..cf0310d4d 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -15,7 +15,6 @@ open Network_utils open Xapi_stdext_pervasives -open Xapi_stdext_std.Listext open Xapi_stdext_threads.Threadext module D = Debug.Make(struct let name = "network_monitor_thread" end) @@ -157,7 +156,7 @@ let rec monitor dbg () = (List.map (make_bond_info devs) bonds) @ devs in let transform_taps devs = - let newdevnames = List.setify (List.map fst devs) in + let newdevnames = Xapi_stdext_std.Listext.List.setify (List.map fst devs) in List.map (fun name -> let devs' = List.filter (fun (n,x) -> n=name) devs in let tot = List.fold_left (fun acc (_,b) -> diff --git a/networkd/network_server.ml b/networkd/network_server.ml index b48f694e0..bfc4d9d7a 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -15,8 +15,6 @@ open Network_utils open Network_interface -open Xapi_stdext_std.Listext - (* Backport of stdext rtrim using Astring functions *) let rtrim s = let open Astring in @@ -206,8 +204,8 @@ module Interface = struct (* the function is meant to be idempotent and we * want to avoid CA-239919 *) let cur_addrs = Ip.get_ipv4 name in - let rm_addrs = List.set_difference cur_addrs addrs in - let add_addrs = List.set_difference addrs cur_addrs in + let rm_addrs = Xapi_stdext_std.Listext.List.set_difference cur_addrs addrs in + let add_addrs = Xapi_stdext_std.Listext.List.set_difference addrs cur_addrs in List.iter (Ip.del_ip_addr name) rm_addrs; List.iter (Ip.set_ip_addr name) add_addrs ) () @@ -281,11 +279,11 @@ module Interface = struct let addrs = Ip.get_ipv6 name in let maybe_link_local = Ip.split_addr (Ip.get_ipv6_link_local_addr name) in match maybe_link_local with - | Some addr -> List.setify (addr :: addrs) + | Some addr -> Xapi_stdext_std.Listext.List.setify (addr :: addrs) | None -> addrs in - let rm_addrs = List.set_difference cur_addrs addrs in - let add_addrs = List.set_difference addrs cur_addrs in + let rm_addrs = Xapi_stdext_std.Listext.List.set_difference cur_addrs addrs in + let add_addrs = Xapi_stdext_std.Listext.List.set_difference addrs cur_addrs in List.iter (Ip.del_ip_addr name) rm_addrs; List.iter (Ip.set_ip_addr name) add_addrs ) () @@ -844,7 +842,7 @@ module Bridge = struct Linux_bonding.add_bond_master name; let bond_properties = if List.mem_assoc "mode" bond_properties && List.assoc "mode" bond_properties = "lacp" then - List.replace_assoc "mode" "802.3ad" bond_properties + Xapi_stdext_std.Listext.List.replace_assoc "mode" "802.3ad" bond_properties else bond_properties in Linux_bonding.set_bond_properties name bond_properties; @@ -981,7 +979,7 @@ module Bridge = struct let persistent_config = List.filter (fun (name, bridge) -> bridge.persistent_b) config in debug "Ensuring the following persistent bridges are up: %s" (String.concat ", " (List.map (fun (name, _) -> name) persistent_config)); - let vlan_parents = List.filter_map (function + let vlan_parents = Xapi_stdext_std.Listext.List.filter_map (function | (_, {vlan=Some (parent, _)}) -> if not (List.mem_assoc parent persistent_config) then Some (parent, List.assoc parent config) From fa700aa1f100c089696c1580649f881615197cb9 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Thu, 14 Dec 2017 11:44:41 +0000 Subject: [PATCH 162/260] Remove rtrim, replace with Astring.String.trim Signed-off-by: Marcello Seri --- lib/network_config.ml | 16 +--------------- lib/network_utils.ml | 36 +++++++++++------------------------- networkd/network_server.ml | 18 ++---------------- 3 files changed, 14 insertions(+), 56 deletions(-) diff --git a/lib/network_config.ml b/lib/network_config.ml index 0c6ce5b96..79d2d0d8f 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -17,20 +17,6 @@ open Network_interface module D = Debug.Make(struct let name = "network_config" end) open D -(* Backport of stdext rtrim using Astring functions *) -let rtrim s = - let open Astring in - let drop = Char.Ascii.is_white in - let len = String.length s in - if len = 0 then s else - let max_idx = len - 1 in - let rec right_pos i = - if i < 0 then 0 else - if drop (String.unsafe_get s i) then right_pos (i - 1) else (i + 1) - in - let right = right_pos max_idx in - if right = len then s else String.take ~max:right s - exception Read_error exception Write_error @@ -44,7 +30,7 @@ let bridge_naming_convention (device: string) = let read_management_conf () = try let management_conf = Xapi_stdext_unix.Unixext.string_of_file ("/etc/firstboot.d/data/management.conf") in - let args = Astring.String.cuts ~empty:false ~sep:"\n" (rtrim management_conf) in + let args = Astring.String.cuts ~empty:false ~sep:"\n" (Astring.String.trim management_conf) in let args = List.map (fun s -> match (Astring.String.cuts ~empty:false ~sep:"=" s) with | k :: [v] -> k, Astring.String.trim ~drop:((=) '\'') v diff --git a/lib/network_utils.ml b/lib/network_utils.ml index db26457e1..5dbd8277a 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -14,20 +14,6 @@ open Xapi_stdext_pervasives -(* Backport of stdext rtrim using Astring functions *) -let rtrim s = - let open Astring in - let drop = Char.Ascii.is_white in - let len = String.length s in - if len = 0 then s else - let max_idx = len - 1 in - let rec right_pos i = - if i < 0 then 0 else - if drop (String.unsafe_get s i) then right_pos (i - 1) else (i + 1) - in - let right = right_pos max_idx in - if right = len then s else String.take ~max:right s - open Network_interface module D = Debug.Make(struct let name = "network_utils" end) @@ -780,12 +766,12 @@ module Ovs = struct let port_to_interfaces name = try let raw = vsctl ["get"; "port"; name; "interfaces"] in - let raw = rtrim raw in + let raw = Astring.String.trim raw in if raw <> "[]" then let raw_list = (Astring.String.cuts ~empty:false ~sep:"," (String.sub raw 1 (String.length raw - 2))) in let uuids = List.map (Astring.String.trim) raw_list in List.map (fun uuid -> - let raw = rtrim (vsctl ["get"; "interface"; uuid; "name"]) in + let raw = Astring.String.trim (vsctl ["get"; "interface"; uuid; "name"]) in String.sub raw 1 (String.length raw - 2)) uuids else [] @@ -793,7 +779,7 @@ module Ovs = struct let bridge_to_ports name = try - let ports = rtrim (vsctl ["list-ports"; name]) in + let ports = Astring.String.trim (vsctl ["list-ports"; name]) in let ports' = if ports <> "" then Astring.String.cuts ~empty:false ~sep:"\n" ports @@ -805,7 +791,7 @@ module Ovs = struct let bridge_to_interfaces name = try - let ifaces = rtrim (vsctl ["list-ifaces"; name]) in + let ifaces = Astring.String.trim (vsctl ["list-ifaces"; name]) in if ifaces <> "" then Astring.String.cuts ~empty:false ~sep:"\n" ifaces else @@ -814,8 +800,8 @@ module Ovs = struct let bridge_to_vlan name = try - let parent = vsctl ["br-to-parent"; name] |> rtrim in - let vlan = vsctl ["br-to-vlan"; name] |> rtrim |> int_of_string in + let parent = vsctl ["br-to-parent"; name] |> Astring.String.trim in + let vlan = vsctl ["br-to-vlan"; name] |> Astring.String.trim |> int_of_string in Some (parent, vlan) with e -> debug "bridge_to_vlan: %s" (Printexc.to_string e); @@ -854,7 +840,7 @@ module Ovs = struct let get_bond_mode name = try - let output = rtrim (vsctl ["get"; "port"; name; "bond_mode"]) in + let output = Astring.String.trim (vsctl ["get"; "port"; name; "bond_mode"]) in if output <> "[]" then Some output else None with _ -> None @@ -905,14 +891,14 @@ module Ovs = struct let vlans_with_uuid = let raw = vsctl ["--bare"; "-f"; "table"; "--"; "--columns=name,_uuid"; "find"; "port"; "fake_bridge=true"] in if raw <> "" then - let lines = Astring.String.cuts ~empty:false ~sep:"\n" (rtrim raw) in + let lines = Astring.String.cuts ~empty:false ~sep:"\n" (Astring.String.trim raw) in List.map (fun line -> Scanf.sscanf line "%s %s" (fun a b-> a, b)) lines else [] in let bridge_ports = let raw = vsctl ["get"; "bridge"; name; "ports"] in - let raw = rtrim raw in + let raw = Astring.String.trim raw in if raw <> "[]" then let raw_list = (Astring.String.cuts ~empty:false ~sep:"," (String.sub raw 1 (String.length raw - 2))) in List.map Astring.String.trim raw_list @@ -934,7 +920,7 @@ module Ovs = struct let get_mcast_snooping_enable ~name = try vsctl ~log:true ["--"; "get"; "bridge"; name; "mcast_snooping_enable"] - |> rtrim + |> Astring.String.trim |> bool_of_string with _ -> false @@ -1017,7 +1003,7 @@ module Ovs = struct vsctl ~log:true ["--"; "--if-exists"; "del-br"; name] let list_bridges () = - let bridges = rtrim (vsctl ["list-br"]) in + let bridges = Astring.String.trim (vsctl ["list-br"]) in if bridges <> "" then Astring.String.cuts ~empty:false ~sep:"\n" bridges else diff --git a/networkd/network_server.ml b/networkd/network_server.ml index bfc4d9d7a..e32745d96 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -15,20 +15,6 @@ open Network_utils open Network_interface -(* Backport of stdext rtrim using Astring functions *) -let rtrim s = - let open Astring in - let drop = Char.Ascii.is_white in - let len = String.length s in - if len = 0 then s else - let max_idx = len - 1 in - let rec right_pos i = - if i < 0 then 0 else - if drop (String.unsafe_get s i) then right_pos (i - 1) else (i + 1) - in - let right = right_pos max_idx in - if right = len then s else String.take ~max:right s - module D = Debug.Make(struct let name = "network_server" end) open D @@ -521,7 +507,7 @@ module Bridge = struct | Openvswitch -> let bridges = let raw = Ovs.vsctl ["--bare"; "-f"; "table"; "--"; "--columns=name"; "find"; "port"; "fake_bridge=true"; "tag=" ^ (string_of_int vlan)] in - if raw <> "" then Astring.String.cuts ~empty:false ~sep:"\n" (rtrim raw) else [] + if raw <> "" then Astring.String.cuts ~empty:false ~sep:"\n" (Astring.String.trim raw) else [] in let existing_bridges = List.filter ( fun bridge -> @@ -1045,7 +1031,7 @@ let on_startup () = (* Remove DNSDEV and GATEWAYDEV from Centos networking file, because the interfere * with this daemon. *) try - let file = rtrim (Xapi_stdext_unix.Unixext.string_of_file "/etc/sysconfig/network") in + let file = Astring.String.trim (Xapi_stdext_unix.Unixext.string_of_file "/etc/sysconfig/network") in let args = Astring.String.cuts ~empty:false ~sep:"\n" file in let args = List.map (fun s -> match (Astring.String.cuts ~empty:false ~sep:"=" s) with k :: [v] -> k, v | _ -> "", "") args in let args = List.filter (fun (k, v) -> k <> "DNSDEV" && k <> "GATEWAYDEV") args in From 10fc781ce3b24d023009ba768da5d91c39686b69 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Thu, 14 Dec 2017 12:13:48 +0000 Subject: [PATCH 163/260] Use String.trim instead of Astring.String.trim when possible Signed-off-by: Marcello Seri --- lib/network_config.ml | 2 +- lib/network_utils.ml | 32 ++++++++++++++-------------- networkd/network_server.ml | 6 +++--- test/network_test_lacp_properties.ml | 2 +- 4 files changed, 21 insertions(+), 21 deletions(-) diff --git a/lib/network_config.ml b/lib/network_config.ml index 79d2d0d8f..297e5047b 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -30,7 +30,7 @@ let bridge_naming_convention (device: string) = let read_management_conf () = try let management_conf = Xapi_stdext_unix.Unixext.string_of_file ("/etc/firstboot.d/data/management.conf") in - let args = Astring.String.cuts ~empty:false ~sep:"\n" (Astring.String.trim management_conf) in + let args = Astring.String.cuts ~empty:false ~sep:"\n" (String.trim management_conf) in let args = List.map (fun s -> match (Astring.String.cuts ~empty:false ~sep:"=" s) with | k :: [v] -> k, Astring.String.trim ~drop:((=) '\'') v diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 5dbd8277a..3c6e70e8e 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -90,7 +90,7 @@ module Sysfs = struct let get_driver_version driver () = try - Some (Astring.String.trim (Xapi_stdext_unix.Unixext.string_of_file ("/sys/bus/pci/drivers/" ^ driver ^ "/module/version"))) + Some (String.trim (Xapi_stdext_unix.Unixext.string_of_file ("/sys/bus/pci/drivers/" ^ driver ^ "/module/version"))) with _ -> warn "Failed to obtain driver version from sysfs"; None @@ -695,11 +695,11 @@ module Proc = struct try Scanf.sscanf line "%s@: %s@\n" (fun k v -> if k = "Slave Interface" then begin - let interface = Some (Astring.String.trim v) in + let interface = Some (String.trim v) in loop interface acc tail end else if k = key then match current with - | Some interface -> loop current ((interface, Astring.String.trim v) :: acc) tail + | Some interface -> loop current ((interface, String.trim v) :: acc) tail | None -> loop current acc tail else loop current acc tail @@ -766,12 +766,12 @@ module Ovs = struct let port_to_interfaces name = try let raw = vsctl ["get"; "port"; name; "interfaces"] in - let raw = Astring.String.trim raw in + let raw = String.trim raw in if raw <> "[]" then let raw_list = (Astring.String.cuts ~empty:false ~sep:"," (String.sub raw 1 (String.length raw - 2))) in - let uuids = List.map (Astring.String.trim) raw_list in + let uuids = List.map (String.trim) raw_list in List.map (fun uuid -> - let raw = Astring.String.trim (vsctl ["get"; "interface"; uuid; "name"]) in + let raw = String.trim (vsctl ["get"; "interface"; uuid; "name"]) in String.sub raw 1 (String.length raw - 2)) uuids else [] @@ -779,7 +779,7 @@ module Ovs = struct let bridge_to_ports name = try - let ports = Astring.String.trim (vsctl ["list-ports"; name]) in + let ports = String.trim (vsctl ["list-ports"; name]) in let ports' = if ports <> "" then Astring.String.cuts ~empty:false ~sep:"\n" ports @@ -791,7 +791,7 @@ module Ovs = struct let bridge_to_interfaces name = try - let ifaces = Astring.String.trim (vsctl ["list-ifaces"; name]) in + let ifaces = String.trim (vsctl ["list-ifaces"; name]) in if ifaces <> "" then Astring.String.cuts ~empty:false ~sep:"\n" ifaces else @@ -800,8 +800,8 @@ module Ovs = struct let bridge_to_vlan name = try - let parent = vsctl ["br-to-parent"; name] |> Astring.String.trim in - let vlan = vsctl ["br-to-vlan"; name] |> Astring.String.trim |> int_of_string in + let parent = vsctl ["br-to-parent"; name] |> String.trim in + let vlan = vsctl ["br-to-vlan"; name] |> String.trim |> int_of_string in Some (parent, vlan) with e -> debug "bridge_to_vlan: %s" (Printexc.to_string e); @@ -840,7 +840,7 @@ module Ovs = struct let get_bond_mode name = try - let output = Astring.String.trim (vsctl ["get"; "port"; name; "bond_mode"]) in + let output = String.trim (vsctl ["get"; "port"; name; "bond_mode"]) in if output <> "[]" then Some output else None with _ -> None @@ -891,17 +891,17 @@ module Ovs = struct let vlans_with_uuid = let raw = vsctl ["--bare"; "-f"; "table"; "--"; "--columns=name,_uuid"; "find"; "port"; "fake_bridge=true"] in if raw <> "" then - let lines = Astring.String.cuts ~empty:false ~sep:"\n" (Astring.String.trim raw) in + let lines = Astring.String.cuts ~empty:false ~sep:"\n" (String.trim raw) in List.map (fun line -> Scanf.sscanf line "%s %s" (fun a b-> a, b)) lines else [] in let bridge_ports = let raw = vsctl ["get"; "bridge"; name; "ports"] in - let raw = Astring.String.trim raw in + let raw = String.trim raw in if raw <> "[]" then let raw_list = (Astring.String.cuts ~empty:false ~sep:"," (String.sub raw 1 (String.length raw - 2))) in - List.map Astring.String.trim raw_list + List.map String.trim raw_list else [] in @@ -920,7 +920,7 @@ module Ovs = struct let get_mcast_snooping_enable ~name = try vsctl ~log:true ["--"; "get"; "bridge"; name; "mcast_snooping_enable"] - |> Astring.String.trim + |> String.trim |> bool_of_string with _ -> false @@ -1003,7 +1003,7 @@ module Ovs = struct vsctl ~log:true ["--"; "--if-exists"; "del-br"; name] let list_bridges () = - let bridges = Astring.String.trim (vsctl ["list-br"]) in + let bridges = String.trim (vsctl ["list-br"]) in if bridges <> "" then Astring.String.cuts ~empty:false ~sep:"\n" bridges else diff --git a/networkd/network_server.ml b/networkd/network_server.ml index e32745d96..753a281b9 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -477,7 +477,7 @@ module Bridge = struct let determine_backend () = try - let backend = Astring.String.trim (Xapi_stdext_unix.Unixext.string_of_file !network_conf) in + let backend = String.trim (Xapi_stdext_unix.Unixext.string_of_file !network_conf) in match backend with | "openvswitch" | "vswitch" -> backend_kind := Openvswitch | "bridge" -> backend_kind := Bridge @@ -507,7 +507,7 @@ module Bridge = struct | Openvswitch -> let bridges = let raw = Ovs.vsctl ["--bare"; "-f"; "table"; "--"; "--columns=name"; "find"; "port"; "fake_bridge=true"; "tag=" ^ (string_of_int vlan)] in - if raw <> "" then Astring.String.cuts ~empty:false ~sep:"\n" (Astring.String.trim raw) else [] + if raw <> "" then Astring.String.cuts ~empty:false ~sep:"\n" (String.trim raw) else [] in let existing_bridges = List.filter ( fun bridge -> @@ -1031,7 +1031,7 @@ let on_startup () = (* Remove DNSDEV and GATEWAYDEV from Centos networking file, because the interfere * with this daemon. *) try - let file = Astring.String.trim (Xapi_stdext_unix.Unixext.string_of_file "/etc/sysconfig/network") in + let file = String.trim (Xapi_stdext_unix.Unixext.string_of_file "/etc/sysconfig/network") in let args = Astring.String.cuts ~empty:false ~sep:"\n" file in let args = List.map (fun s -> match (Astring.String.cuts ~empty:false ~sep:"=" s) with k :: [v] -> k, v | _ -> "", "") args in let args = List.filter (fun (k, v) -> k <> "DNSDEV" && k <> "GATEWAYDEV") args in diff --git a/test/network_test_lacp_properties.ml b/test/network_test_lacp_properties.ml index cf5016ad5..f8c23c419 100644 --- a/test/network_test_lacp_properties.ml +++ b/test/network_test_lacp_properties.ml @@ -90,7 +90,7 @@ let test_lacp_aggregation_key_vsctl arg () = skip_if true "Unimplemented" ; print_endline answer ; assert_bool "lacp_aggregation_key is passed to ovs-vsctl command" (List.exists - (fun s -> (Astring.String.trim s) == answer) + (fun s -> (String.trim s) == answer) !OVS_Cli_test.vsctl_output) (* Test case for bond_create with default lacp-{time,aggregation-key} settings. From abe946ddee7490828414d886c0b15a837621028b Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Thu, 14 Dec 2017 13:53:44 +0000 Subject: [PATCH 164/260] Compile with -safe-string Signed-off-by: Marcello Seri --- lib/jbuild | 2 +- networkd/jbuild | 2 +- networkd/network_monitor_thread.ml | 2 +- networkd_db/jbuild | 2 +- profiling/jbuild | 2 +- test/jbuild | 2 +- 6 files changed, 6 insertions(+), 6 deletions(-) diff --git a/lib/jbuild b/lib/jbuild index 656c39780..719f2f191 100644 --- a/lib/jbuild +++ b/lib/jbuild @@ -2,7 +2,7 @@ (library ((name networklibs) - (flags (:standard :standard -bin-annot)) + (flags (:standard :standard -bin-annot -safe-string)) (libraries (astring forkexec rpclib diff --git a/networkd/jbuild b/networkd/jbuild index 0194f7d10..a757b7b01 100644 --- a/networkd/jbuild +++ b/networkd/jbuild @@ -16,7 +16,7 @@ ((name networkd) (public_name xapi-networkd) (package xapi-networkd) - (flags (:standard -bin-annot)) + (flags (:standard -bin-annot -safe-string)) (libraries (forkexec netlink networklibs diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index cf0310d4d..21d2ed23f 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -268,7 +268,7 @@ let signal_networking_change () = (* Remove all outstanding reads on a file descriptor *) let clear_input fd = - let buf = String.make 255 ' ' in + let buf = Bytes.make 255 ' ' in let rec loop () = try ignore (Unix.read fd buf 0 255); diff --git a/networkd_db/jbuild b/networkd_db/jbuild index e6c23c97a..0ff324a83 100644 --- a/networkd_db/jbuild +++ b/networkd_db/jbuild @@ -2,7 +2,7 @@ ((name networkd_db) (public_name networkd_db) (package xapi-networkd) - (flags (:standard -bin-annot)) + (flags (:standard -bin-annot -safe-string)) (libraries (networklibs profiling threads diff --git a/profiling/jbuild b/profiling/jbuild index 76fc54b0a..2115356d3 100644 --- a/profiling/jbuild +++ b/profiling/jbuild @@ -2,7 +2,7 @@ (library ((name profiling) - (flags (:standard -bin-annot)) + (flags (:standard -bin-annot -safe-string)) (wrapped false) ) ) \ No newline at end of file diff --git a/test/jbuild b/test/jbuild index 60714966f..8c8a9e186 100644 --- a/test/jbuild +++ b/test/jbuild @@ -1,6 +1,6 @@ (executable ((name network_test) - (flags (:standard -bin-annot)) + (flags (:standard -bin-annot -safe-string)) (libraries (astring networklibs oUnit From 85aa22989e8b0753995b1783cad9712474242cee Mon Sep 17 00:00:00 2001 From: Wei Xie Date: Fri, 15 Dec 2017 15:35:20 +0800 Subject: [PATCH 165/260] CA-276745: Fix Networkd.Sysfs.get_driver_name Signed-off-by: Wei Xie --- lib/network_utils.ml | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 3c6e70e8e..83f32e016 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -154,13 +154,12 @@ module Sysfs = struct (** Returns the name of the driver for network device [dev] *) let get_driver_name dev = try - let symlink = getpath dev "device/driver" in - let target = Unix.readlink symlink in - match Astring.String.cut ~sep:"/" target with - | Some (prefix, suffix) -> Some prefix + let driver_path = Unix.readlink (getpath dev "device/driver") in + match Astring.String.cut ~sep:"/" ~rev:true driver_path with + | Some (prefix, suffix) -> Some suffix | None -> - debug "target %s of symbolic link %s does not contain slash" target symlink; - None + debug "get %s driver name: %s does not contain slash" dev driver_path; + None with _ -> debug "%s: could not read netdev's driver name" dev; None From e64c380b3ed7cfc6ea0dbd90830b112e47ed1385 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 15 Dec 2017 11:15:25 +0000 Subject: [PATCH 166/260] Remove CLI This isn't used, and we'll get a new, better one through the upcoming PPX changes. Signed-off-by: Rob Hoes --- cli/jbuild | 15 -- cli/network_cli.ml | 354 --------------------------------------------- 2 files changed, 369 deletions(-) delete mode 100644 cli/jbuild delete mode 100644 cli/network_cli.ml diff --git a/cli/jbuild b/cli/jbuild deleted file mode 100644 index 67ec86e82..000000000 --- a/cli/jbuild +++ /dev/null @@ -1,15 +0,0 @@ -(executable - ((name network_cli) - (public_name networkd-cli) - (package xapi-networkd) - (flags (:standard -bin-annot)) - (libraries (astring - cmdliner - networklibs - profiling - xapi-stdext-unix - xcp - xcp.network) - ) - ) -) diff --git a/cli/network_cli.ml b/cli/network_cli.ml deleted file mode 100644 index 682981ad9..000000000 --- a/cli/network_cli.ml +++ /dev/null @@ -1,354 +0,0 @@ -open Network_interface -open Network_client -open Cmdliner - -let dbg = "cli" - -let (|>) x f = f x - -(* Interface commands *) - -let iface_arg = - let doc = "Interface name" in - Arg.(required & pos 0 (some string) None & info [] ~docv:"INTERFACE" ~doc) - -let list_iface () = - let all = Client.Interface.get_all dbg () in - List.iter print_endline all - -let list_iface_cmd = - let doc = "List all interfaces" in - let man = [] in - Term.(pure list_iface $ pure ()), - Term.info "list-iface" ~doc ~man - -let get_mac iface = - try - let mac = Client.Interface.get_mac dbg iface in - `Ok (print_endline mac) - with _ -> - `Error (false, iface ^ " is not an interface") - -let get_mac_cmd = - let doc = "Get the MAC address of an interface" in - let man = [] in - Term.(ret (pure get_mac $ iface_arg)), - Term.info "get-mac" ~doc ~man - -let is_up iface = - try - let up = Client.Interface.is_up dbg iface in - `Ok (print_endline (if up then "up" else "not up")) - with _ -> - `Error (false, iface ^ " is not an interface") - -let is_up_cmd = - let doc = "Check whether an interface is up or down" in - let man = [] in - Term.(ret (pure is_up $ iface_arg)), - Term.info "is-up" ~doc ~man - -let get_ipv4_addr iface = - try - let addrs = Client.Interface.get_ipv4_addr dbg iface in - List.iter (fun (addr, prefix) -> - Printf.printf "%s/%d\n" (Unix.string_of_inet_addr addr) prefix - ) addrs; - `Ok () - with _ -> - `Error (false, iface ^ " is not an interface") - -let get_ipv4_addr_cmd = - let doc = "Get IPv4 addresses (CIDRs) of an interface" in - let man = [] in - Term.(ret (pure get_ipv4_addr $ iface_arg)), - Term.info "get-ipv4-addr" ~doc ~man - -let set_ipv4_addr iface conf = - try - let conf' = - if conf = "none" then - None4 - else if conf = "dhcp" then - DHCP4 - else - let i = String.index conf '/' in - let n = String.length conf in - let addr = Unix.inet_addr_of_string (String.sub conf 0 i) in - let prefix = String.sub conf (i + 1) (n - i - 1) |> int_of_string in - Static4 [addr, prefix] - in - Client.Interface.set_ipv4_conf dbg iface conf'; - `Ok () - with _ -> - `Error (false, "something went wrong") - -let set_ipv4_addr_cmd = - let doc = "Interface name (none|dhcp|)" in - let conf_arg = Arg.(required & pos 1 (some string) None & info [] ~docv:"IPV4-CONF" ~doc) in - let doc = "Set IPv4 configuration of an interface" in - let man = [] in - Term.(ret (pure set_ipv4_addr $ iface_arg $ conf_arg)), - Term.info "set-ipv4-addr" ~doc ~man - -let get_ipv4_gateway iface = - try - let addr = Client.Interface.get_ipv4_gateway dbg iface in - (match addr with - | Some addr -> Printf.printf "%s\n" (Unix.string_of_inet_addr addr) - | None -> () - ); - `Ok () - with _ -> - `Error (false, iface ^ " is not an interface") - -let get_ipv4_gateway_cmd = - let doc = "If there is an IPv4 default route through the interface, get the gateway address" in - let man = [] in - Term.(ret (pure get_ipv4_gateway $ iface_arg)), - Term.info "get-ipv4-gateway" ~doc ~man - -let set_ipv4_gateway iface addr = - try - let addr' = Unix.inet_addr_of_string addr in - Client.Interface.set_ipv4_gateway dbg iface addr'; - `Ok () - with _ -> - `Error (false, "something went wrong") - -let set_ipv4_gateway_cmd = - let doc = "Gateway IPv4 address" in - let addr_arg = Arg.(required & pos 1 (some string) None & info [] ~docv:"IPV4-GATEWAY" ~doc) in - let doc = "Set IPv4 gateway for an interface" in - let man = [] in - Term.(ret (pure set_ipv4_gateway $ iface_arg $ addr_arg)), - Term.info "set-ipv4-gateway" ~doc ~man - -let get_ipv6_addr iface = - try - let addrs = Client.Interface.get_ipv6_addr dbg iface in - List.iter (fun (addr, prefix) -> - Printf.printf "%s/%d\n" (Unix.string_of_inet_addr addr) prefix - ) addrs; - `Ok () - with _ -> - `Error (false, iface ^ " is not an interface") - -let get_ipv6_addr_cmd = - let doc = "Get IPv6 addresses (CIDRs) of an interface" in - let man = [] in - Term.(ret (pure get_ipv6_addr $ iface_arg)), - Term.info "get-ipv6-addr" ~doc ~man - -let set_ipv6_addr iface conf = - try - let conf' = - if conf = "none" then - None6 - else if conf = "linklocal" then - Linklocal6 - else if conf = "dhcp" then - DHCP6 - else if conf = "autoconf" then - Autoconf6 - else - let i = String.index conf '/' in - let n = String.length conf in - let addr = Unix.inet_addr_of_string (String.sub conf 0 i) in - let prefix = String.sub conf (i + 1) (n - i - 1) |> int_of_string in - Static6 [addr, prefix] - in - Client.Interface.set_ipv6_conf dbg iface conf'; - `Ok () - with _ -> - `Error (false, "something went wrong") - -let set_ipv6_addr_cmd = - let doc = "Interface name (none|linklocal|dhcp|autoconf|)" in - let conf_arg = Arg.(required & pos 1 (some string) None & info [] ~docv:"IPV6-CONF" ~doc) in - let doc = "Set IPv6 configuration of an interface" in - let man = [] in - Term.(ret (pure set_ipv6_addr $ iface_arg $ conf_arg)), - Term.info "set-ipv6-addr" ~doc ~man - -let get_ipv6_gateway iface = - try - let addr = Client.Interface.get_ipv6_gateway dbg iface in - (match addr with - | Some addr -> Printf.printf "%s\n" (Unix.string_of_inet_addr addr) - | None -> () - ); - `Ok () - with _ -> - `Error (false, iface ^ " is not an interface") - -let get_ipv6_gateway_cmd = - let doc = "If there is an IPv6 default route through the interface, get the gateway address" in - let man = [] in - Term.(ret (pure get_ipv6_gateway $ iface_arg)), - Term.info "get-ipv6-gateway" ~doc ~man - -let set_ipv6_gateway iface addr = - try - let addr' = Unix.inet_addr_of_string addr in - Client.Interface.set_ipv6_gateway dbg iface addr'; - `Ok () - with _ -> - `Error (false, "something went wrong") - -let set_ipv6_gateway_cmd = - let doc = "Gateway IPv6 address" in - let addr_arg = Arg.(required & pos 1 (some string) None & info [] ~docv:"IPV6-GATEWAY" ~doc) in - let doc = "Set IPv6 gateway for an interface" in - let man = [] in - Term.(ret (pure set_ipv6_gateway $ iface_arg $ addr_arg)), - Term.info "set-ipv6-gateway" ~doc ~man - -let get_dns () = - let nameservers, domains = Client.Interface.get_dns dbg "" in - Printf.printf "nameservers: %s\n" (String.concat ", " (List.map Unix.string_of_inet_addr nameservers)); - Printf.printf "domains: %s\n" (String.concat ", " domains); - `Ok () - -let get_dns_cmd = - let doc = "Get DNS nameservers and domains" in - let man = [] in - Term.(ret (pure get_dns $ pure ())), - Term.info "get-dns" ~doc ~man - -let set_dns iface nameservers domains = - try - let ns = match nameservers with - | Some x -> List.map Unix.inet_addr_of_string (Astring.String.cuts ~empty:false ~sep:"," x) - | None -> [] - in - let d = match domains with - | Some x -> Astring.String.cuts ~empty:false ~sep:"," x - | None -> [] - in - Client.Interface.set_dns dbg iface ns d; - `Ok () - with _ -> - `Error (false, "something went wrong") - -let set_dns_cmd = - let doc = "Comma-separated list of nameservers" in - let nameservers_arg = Arg.(value & opt (some string) None & info ["nameservers"] ~docv:"NAMESERVERS" ~doc) in - let doc = "Comma-separated list of domains" in - let domains_arg = Arg.(value & opt (some string) None & info ["domains"] ~docv:"DOMAINS" ~doc) in - let doc = "Set DNS nameservers and domains" in - let man = [] in - Term.(ret (pure set_dns $ iface_arg $ nameservers_arg $ domains_arg)), - Term.info "set-dns" ~doc ~man - -let get_mtu iface = - try - let mtu = Client.Interface.get_mtu dbg iface in - Printf.printf "%d\n" mtu; - `Ok () - with _ -> - `Error (false, iface ^ " is not an interface") - -let get_mtu_cmd = - let doc = "Get MTU" in - let man = [] in - Term.(ret (pure get_mtu $ iface_arg)), - Term.info "get-mtu" ~doc ~man - -let set_mtu iface mtu = - try - Client.Interface.set_mtu dbg iface mtu; - `Ok () - with _ -> - `Error (false, iface ^ " is not an interface") - -let set_mtu_cmd = - let doc = "The MTU" in - let mtu_arg = Arg.(required & pos 1 (some int) None & info [] ~docv:"MTU" ~doc) in - let doc = "Get MTU" in - let man = [] in - Term.(ret (pure set_mtu $ iface_arg $ mtu_arg)), - Term.info "set-mtu" ~doc ~man - -let get_persistence iface = - try - let persistent = Client.Interface.is_persistent dbg iface in - Printf.printf "%s\n" (if persistent then "persistent" else "not persistent"); - `Ok () - with _ -> - `Error (false, iface ^ " is not an interface") - -let get_persistence_cmd = - let doc = "Get persistence" in - let man = [] in - Term.(ret (pure get_persistence $ iface_arg)), - Term.info "get-persistence" ~doc ~man - -let set_persistence iface persistence = - try - if persistence = "on" then - `Ok (Client.Interface.set_persistent dbg iface true) - else if persistence = "off" then - `Ok (Client.Interface.set_persistent dbg iface false) - else - `Error (false, "'on' or 'off' please") - with _ -> - `Error (false, iface ^ " is not an interface") - -let set_persistence_cmd = - let doc = "Persistence (on|off)" in - let persistence_arg = Arg.(required & pos 1 (some string) None & info [] ~docv:"PERSISTENCE" ~doc) in - let doc = "Set persistence" in - let man = [] in - Term.(ret (pure set_persistence $ iface_arg $ persistence_arg)), - Term.info "set-persistence" ~doc ~man - -(* Bridge commands *) - -let list_br () = - let all = Client.Bridge.get_all dbg () in - List.iter print_endline all - -let list_br_cmd = - let doc = "List all bridges" in - let man = [] in - Term.(pure list_br $ pure ()), - Term.info "list-br" ~doc ~man - -let read_config path = - let config_json = Xapi_stdext_unix.Unixext.string_of_file path in - config_json |> Jsonrpc.of_string |> config_t_of_rpc - -let config path = - let config = read_config path in - Client.Bridge.make_config dbg ~config:config.bridge_config (); - Client.Interface.make_config dbg ~config:config.interface_config (); - `Ok () - -let config_cmd = - let doc = "Path to JSON config file" in - let config_arg = Arg.(required & pos 0 (some file) None & info [] ~docv:"CONFIG-FILE" ~doc) in - let doc = "Set network configuration based on a config file" in - let man = [] in - Term.(ret (pure config $ config_arg)), - Term.info "config" ~doc ~man - -let default_cmd = - let doc = "CLI for xcp-networkd" in - let man = [] in - Term.(ret (pure (`Help (`Pager, None)))), - Term.info "network-cli" ~version:"0.1" ~doc ~man - -let cmds = [ - list_iface_cmd; get_mac_cmd; is_up_cmd; - get_ipv4_addr_cmd; set_ipv4_addr_cmd; get_ipv4_gateway_cmd; set_ipv4_gateway_cmd; - get_ipv6_addr_cmd; set_ipv6_addr_cmd; get_ipv6_gateway_cmd; set_ipv6_gateway_cmd; - get_dns_cmd; set_dns_cmd; get_mtu_cmd; set_mtu_cmd; - get_persistence_cmd; set_persistence_cmd; - list_br_cmd; - config_cmd] - -let _ = - Coverage.init "network_cli"; - match Term.eval_choice default_cmd cmds with - | `Error _ -> exit 1 | _ -> exit 0 From 7bb740d7a1b5aa393c068b24f683a9b8dc908902 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Fri, 19 Jan 2018 11:50:50 +0000 Subject: [PATCH 167/260] network_config, network_server: restore semantics of split During the port to Astring Xstringext.String.split (that preserves empty splitted strings) has been replaced in most places by `Astring.String.cuts ~empty:false` (filtering the empty splitted strings). In most cases this was an optimization. In two cases the difference in behaviour could create issues in some corner cases. This commit restores the old behavior for those. Signed-off-by: Marcello Seri --- lib/network_config.ml | 2 +- networkd/network_server.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/network_config.ml b/lib/network_config.ml index 297e5047b..bde191c25 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -32,7 +32,7 @@ let read_management_conf () = let management_conf = Xapi_stdext_unix.Unixext.string_of_file ("/etc/firstboot.d/data/management.conf") in let args = Astring.String.cuts ~empty:false ~sep:"\n" (String.trim management_conf) in let args = List.map (fun s -> - match (Astring.String.cuts ~empty:false ~sep:"=" s) with + match (Astring.String.cuts ~sep:"=" s) with | k :: [v] -> k, Astring.String.trim ~drop:((=) '\'') v | _ -> "", "" ) args in diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 753a281b9..f7e70dc27 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -1033,7 +1033,7 @@ let on_startup () = try let file = String.trim (Xapi_stdext_unix.Unixext.string_of_file "/etc/sysconfig/network") in let args = Astring.String.cuts ~empty:false ~sep:"\n" file in - let args = List.map (fun s -> match (Astring.String.cuts ~empty:false ~sep:"=" s) with k :: [v] -> k, v | _ -> "", "") args in + let args = List.map (fun s -> match (Astring.String.cuts ~sep:"=" s) with k :: [v] -> k, v | _ -> "", "") args in let args = List.filter (fun (k, v) -> k <> "DNSDEV" && k <> "GATEWAYDEV") args in let s = String.concat "\n" (List.map (fun (k, v) -> k ^ "=" ^ v) args) ^ "\n" in Xapi_stdext_unix.Unixext.write_string_to_file "/etc/sysconfig/network" s From 878b8e96ace0e98be18acbed7425e361fc99fa54 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 15 Feb 2018 10:25:15 +0000 Subject: [PATCH 168/260] jbuilder runtest: make it work when _build is not subdir of source root MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit When you are using jbuilder workspaces the _build dir may not be a subdir of the source root. Tell jbuilder to copy the test files from the source dir to the build dir instead of reading them from the source dir during testing. Signed-off-by: Edwin Török --- test/jbuild | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/jbuild b/test/jbuild index 8c8a9e186..afc6f370d 100644 --- a/test/jbuild +++ b/test/jbuild @@ -12,5 +12,5 @@ (alias ((name runtest) - (deps (network_test.exe)) - (action (chdir ../../.. (run ${<}))))) + (deps (network_test.exe (files_recursively_in jsonrpc_files))) + (action (chdir ../ (run ${<}))))) From bbda3016704584c15a95cfb41fe3b2197d0a7ca8 Mon Sep 17 00:00:00 2001 From: Yang Qian Date: Wed, 17 Jan 2018 15:06:47 +0800 Subject: [PATCH 169/260] CP-26352 Port xcp-networkd from Camlp4 to PPX 1. update implementation per interface changes 1. for interface implementation, move labeled parameter and optional parameter to positional parameter and remove useless tail unit parameter Signed-off-by: Yang Qian --- lib/network_config.ml | 8 +- lib/network_utils.ml | 7 ++ networkd/network_monitor.ml | 2 +- networkd/network_monitor_thread.ml | 4 +- networkd/network_server.ml | 144 +++++++++++++++-------------- networkd/networkd.ml | 43 ++++++++- 6 files changed, 134 insertions(+), 74 deletions(-) diff --git a/lib/network_config.ml b/lib/network_config.ml index bde191c25..479598d00 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -20,6 +20,8 @@ open D exception Read_error exception Write_error +let empty_config = default_config + let config_file_path = "/var/lib/xcp/networkd.db" let bridge_naming_convention (device: string) = @@ -104,7 +106,7 @@ let read_management_conf () = let write_config config = try - let config_json = config |> rpc_of_config_t |> Jsonrpc.to_string in + let config_json = config |> Rpcmarshal.marshal typ_of_config_t |> Jsonrpc.to_string in Xapi_stdext_unix.Unixext.write_string_to_file config_file_path config_json with e -> error "Error while trying to write networkd configuration: %s\n%s" @@ -114,7 +116,9 @@ let write_config config = let read_config () = try let config_json = Xapi_stdext_unix.Unixext.string_of_file config_file_path in - config_json |> Jsonrpc.of_string |> config_t_of_rpc + match config_json |> Jsonrpc.of_string |> Rpcmarshal.unmarshal typ_of_config_t with + | Result.Ok v -> v + | Result.Error e -> raise Read_error with | Unix.Unix_error (Unix.ENOENT, _, file) -> info "Cannot read networkd configuration file %s because it does not exist." file; diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 83f32e016..d41d2e6c0 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -18,6 +18,13 @@ open Network_interface module D = Debug.Make(struct let name = "network_utils" end) open D +exception Script_missing of string +exception Script_error of (string * string) list +exception Read_error of string +exception Write_error of string +exception Not_implemented +exception Vlan_in_use of (string * int) +exception PVS_proxy_connection_error let iproute2 = "/sbin/ip" let resolv_conf = "/etc/resolv.conf" diff --git a/networkd/network_monitor.ml b/networkd/network_monitor.ml index 23e1b9a66..dc4536e5b 100644 --- a/networkd/network_monitor.ml +++ b/networkd/network_monitor.ml @@ -16,7 +16,7 @@ open Network_interface include Network_stats let write_stats stats = - let payload = stats |> rpc_of_stats_t |> Jsonrpc.to_string in + let payload = stats |> Rpcmarshal.marshal typ_of_stats_t |> Jsonrpc.to_string in let checksum = payload |> Digest.string |> Digest.to_hex in let length = String.length payload in let data = Printf.sprintf "%s%s%08x%s" magic checksum length payload in diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index 21d2ed23f..7afad2dd7 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -228,8 +228,8 @@ let rec monitor dbg () = dev, stat ) devs in - - let bonds : (string * string list) list = Network_server.Bridge.get_all_bonds () dbg ~from_cache:true () in + let from_cache = true in + let bonds : (string * string list) list = Network_server.Bridge.get_all_bonds dbg from_cache in let devs = get_link_stats () |> add_bonds bonds |> diff --git a/networkd/network_server.ml b/networkd/network_server.ml index f7e70dc27..5a288d6d7 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -21,7 +21,7 @@ open D type context = unit let network_conf = ref "/etc/xcp/network.conf" -let config : config_t ref = ref empty_config +let config : config_t ref = ref Network_config.empty_config let backend_kind = ref Openvswitch let enic_workaround_until_version = ref "2.3.0.30" @@ -66,15 +66,13 @@ let on_shutdown signal = let on_timer () = write_config () -let reopen_logs _ () = true +let clear_state () = + config := Network_config.empty_config -let clear_state _ () = - config := empty_config - -let reset_state _ () = +let reset_state () = config := Network_config.read_management_conf () -let set_gateway_interface _ dbg ~name = +let set_gateway_interface dbg name = (* Update dhclient conf for interface on changing default gateway. * If new default gateway is not same as gateway_interface from networkd.db then * we need to remove gateway information from gateway_interface *) @@ -91,7 +89,7 @@ let set_gateway_interface _ dbg ~name = debug "Setting gateway interface to %s" name; config := {!config with gateway_interface = Some name} -let set_dns_interface _ dbg ~name = +let set_dns_interface dbg name = debug "Setting DNS interface to %s" name; config := {!config with dns_interface = Some name} @@ -127,24 +125,24 @@ module Interface = struct let update_config name data = config := {!config with interface_config = update_config !config.interface_config name data} - let get_all _ dbg () = + let get_all dbg () = Debug.with_thread_associated dbg (fun () -> Sysfs.list () ) () - let exists _ dbg ~name = + let exists dbg name = Debug.with_thread_associated dbg (fun () -> List.mem name (Sysfs.list ()) ) () - let get_mac _ dbg ~name = + let get_mac dbg name = Debug.with_thread_associated dbg (fun () -> match Linux_bonding.get_bond_master_of name with | Some master -> Proc.get_bond_slave_mac master name | None -> Ip.get_mac name ) () - let is_up _ dbg ~name = + let is_up dbg name = Debug.with_thread_associated dbg (fun () -> if List.mem name (Sysfs.list ()) then Ip.is_up name @@ -152,14 +150,14 @@ module Interface = struct false ) () - let get_ipv4_addr _ dbg ~name = + let get_ipv4_addr dbg name = Debug.with_thread_associated dbg (fun () -> Ip.get_ipv4 name ) () - let set_ipv4_conf _ dbg ~name ~conf = + let set_ipv4_conf dbg name conf = Debug.with_thread_associated dbg (fun () -> - debug "Configuring IPv4 address for %s: %s" name (conf |> rpc_of_ipv4 |> Jsonrpc.to_string); + debug "Configuring IPv4 address for %s: %s" name (conf |> Rpcmarshal.marshal typ_of_ipv4 |> Jsonrpc.to_string); update_config name {(get_config name) with ipv4_conf = conf}; match conf with | None4 -> @@ -196,7 +194,7 @@ module Interface = struct List.iter (Ip.set_ip_addr name) add_addrs ) () - let get_ipv4_gateway _ dbg ~name = + let get_ipv4_gateway dbg name = Debug.with_thread_associated dbg (fun () -> let output = Ip.route_show ~version:Ip.V4 name in try @@ -217,14 +215,14 @@ module Interface = struct debug "%s is NOT the default gateway interface" name ) () - let get_ipv6_addr _ dbg ~name = + let get_ipv6_addr dbg name = Debug.with_thread_associated dbg (fun () -> Ip.get_ipv6 name ) () let set_ipv6_conf _ dbg ~name ~conf = Debug.with_thread_associated dbg (fun () -> - debug "Configuring IPv6 address for %s: %s" name (conf |> rpc_of_ipv6 |> Jsonrpc.to_string); + debug "Configuring IPv6 address for %s: %s" name (conf |> Rpcmarshal.marshal typ_of_ipv6 |> Jsonrpc.to_string); update_config name {(get_config name) with ipv6_conf = conf}; match conf with | None6 -> @@ -297,13 +295,13 @@ module Interface = struct let set_ipv4_routes _ dbg ~name ~routes = Debug.with_thread_associated dbg (fun () -> - debug "Configuring IPv4 static routes for %s: %s" name (String.concat ", " (List.map (fun (i, p, g) -> - Printf.sprintf "%s/%d/%s" (Unix.string_of_inet_addr i) p (Unix.string_of_inet_addr g)) routes)); + debug "Configuring IPv4 static routes for %s: %s" name (String.concat ", " (List.map (fun r -> + Printf.sprintf "%s/%d/%s" (Unix.string_of_inet_addr r.subnet) r.netmask (Unix.string_of_inet_addr r.gateway)) routes)); update_config name {(get_config name) with ipv4_routes = routes}; - List.iter (fun (i, p, g) -> Ip.set_route ~network:(i, p) name g) routes + List.iter (fun r -> Ip.set_route ~network:(r.subnet, r.netmask) name r.gateway) routes ) () - let get_dns _ dbg ~name = + let get_dns dbg name = Debug.with_thread_associated dbg (fun () -> let nameservers, domains = Xapi_stdext_unix.Unixext.file_lines_fold (fun (nameservers, domains) line -> if Astring.String.is_prefix ~affix:"nameserver" line then @@ -334,7 +332,7 @@ module Interface = struct debug "%s is NOT the DNS interface" name ) () - let get_mtu _ dbg ~name = + let get_mtu dbg name = Debug.with_thread_associated dbg (fun () -> Ip.get_mtu name ) () @@ -368,22 +366,22 @@ module Interface = struct Ethtool.set_offload name params ) () - let get_capabilities _ dbg ~name = + let get_capabilities dbg name = Debug.with_thread_associated dbg (fun () -> Fcoe.get_capabilities name ) () - let is_connected _ dbg ~name = + let is_connected dbg name = Debug.with_thread_associated dbg (fun () -> Sysfs.get_carrier name ) () - let is_physical _ dbg ~name = + let is_physical dbg name = Debug.with_thread_associated dbg (fun () -> Sysfs.is_physical name ) () - let has_vlan _ dbg ~name ~vlan = + let has_vlan dbg name vlan = (* Identify the vlan is used by kernel which is unknown to XAPI *) Debug.with_thread_associated dbg (fun () -> List.exists (fun (_, v, p) -> v = vlan && p = name) (Proc.get_vlans ()) @@ -395,7 +393,7 @@ module Interface = struct Ip.link_set_up name ) () - let bring_down _ dbg ~name = + let bring_down dbg name = Debug.with_thread_associated dbg (fun () -> debug "Bringing down interface %s" name; Ip.link_set_down name @@ -406,16 +404,16 @@ module Interface = struct (get_config name).persistent_i ) () - let set_persistent _ dbg ~name ~value = + let set_persistent dbg name value = Debug.with_thread_associated dbg (fun () -> debug "Making interface %s %spersistent" name (if value then "" else "non-"); update_config name {(get_config name) with persistent_i = value} ) () - let make_config _ dbg ?(conservative=false) ~config () = + let make_config dbg conservative config = Debug.with_thread_associated dbg (fun () -> (* Only attempt to configure interfaces that exist in the system *) - let all = get_all () dbg () in + let all = get_all dbg () in let config = List.filter (fun (name, _) -> List.mem name all) config in (* Handle conservativeness *) let config = @@ -448,7 +446,7 @@ module Interface = struct * The `dns` field should really be an option type so that we don't have to derive the intention * of the caller by looking at other fields. *) match ipv4_conf with Static4 _ -> set_dns () dbg ~name ~nameservers ~domains | _ -> ()); - exec (fun () -> set_ipv4_conf () dbg ~name ~conf:ipv4_conf); + exec (fun () -> set_ipv4_conf dbg name ipv4_conf); exec (fun () -> match ipv4_gateway with None -> () | Some gateway -> set_ipv4_gateway () dbg ~name ~address:gateway); (try set_ipv6_conf () dbg ~name ~conf:ipv6_conf with _ -> ()); @@ -495,7 +493,7 @@ module Bridge = struct | Bridge -> Proc.get_bond_links_up name ) () - let get_all _ dbg () = + let get_all dbg () = Debug.with_thread_associated dbg (fun () -> match !backend_kind with | Openvswitch -> Ovs.list_bridges () @@ -535,7 +533,7 @@ module Bridge = struct List.iter (fun bridge -> if bridge <> name then begin debug "Destroying existing bridge %s" bridge; - Interface.bring_down () "Destroying existing bridge" ~name:bridge; + Interface.bring_down "Destroying existing bridge" bridge; remove_config bridge; List.iter (fun dev -> Brctl.destroy_port bridge dev; @@ -545,8 +543,11 @@ module Bridge = struct ) existing_bridges end - let create _ dbg ?vlan ?mac ?igmp_snooping ?(other_config=[]) ~name () = + let create dbg vlan mac igmp_snooping other_config name = Debug.with_thread_associated dbg (fun () -> + let other_config = match other_config with + | Some l -> l + | None -> [] in debug "Creating bridge %s%s" name (match vlan with | None -> "" | Some (parent, vlan) -> Printf.sprintf " (VLAN %d on bridge %s)" vlan parent @@ -639,7 +640,7 @@ module Bridge = struct (String.concat ", " current_interfaces); List.iter (fun interface -> Brctl.destroy_port name interface; - Interface.bring_down () dbg ~name:interface + Interface.bring_down dbg interface ) current_interfaces; (* Now create the new VLAN device and add it to the bridge *) Ip.create_vlan parent_interface vlan; @@ -649,9 +650,9 @@ module Bridge = struct Interface.bring_up () dbg ~name ) () - let destroy _ dbg ?(force=false) ~name () = + let destroy dbg force name = Debug.with_thread_associated dbg (fun () -> - Interface.bring_down () dbg ~name; + Interface.bring_down dbg name; match !backend_kind with | Openvswitch -> let vlans_on_this_parent = Ovs.get_vlans name in @@ -660,10 +661,10 @@ module Bridge = struct remove_config name; let interfaces = (Ovs.bridge_to_interfaces name) @ vlans_on_this_parent in List.iter (fun dev -> - Interface.set_ipv4_conf () dbg ~name:dev ~conf:None4; - Interface.bring_down () dbg ~name:dev + Interface.set_ipv4_conf dbg dev None4; + Interface.bring_down dbg dev ) interfaces; - Interface.set_ipv4_conf () dbg ~name ~conf:None4; + Interface.set_ipv4_conf dbg name None4; ignore (Ovs.destroy_bridge name) end else debug "Not destroying bridge %s, because it has VLANs on top" name @@ -682,9 +683,9 @@ module Bridge = struct debug "Destroying bridge %s" name; remove_config name; List.iter (fun dev -> - Interface.set_ipv4_conf () dbg ~name:dev ~conf:None4; + Interface.set_ipv4_conf dbg dev None4; Brctl.destroy_port name dev; - Interface.bring_down () dbg ~name:dev; + Interface.bring_down dbg dev; if Linux_bonding.is_bond_device dev then Linux_bonding.remove_bond_master dev; if (Astring.String.is_prefix ~affix:"eth" dev || Astring.String.is_prefix ~affix:"bond" dev) && String.contains dev '.' then begin @@ -696,13 +697,13 @@ module Bridge = struct Linux_bonding.remove_bond_master (String.sub dev 0 (n - 2)) end; ) ifs; - Interface.set_ipv4_conf () dbg ~name ~conf:None4; + Interface.set_ipv4_conf dbg name None4; ignore (Brctl.destroy_bridge name) end else debug "Not destroying bridge %s, because it has VLANs on top" name ) () - let get_kind _ dbg () = + let get_kind dbg () = Debug.with_thread_associated dbg (fun () -> !backend_kind ) () @@ -714,7 +715,7 @@ module Bridge = struct | Bridge -> raise Not_implemented ) () - let get_all_ports _ dbg ?(from_cache=false) () = + let get_all_ports dbg from_cache = Debug.with_thread_associated dbg (fun () -> if from_cache then let ports = List.concat (List.map (fun (_, {ports}) -> ports) !config.bridge_config) in @@ -732,7 +733,7 @@ module Bridge = struct | Bridge -> raise Not_implemented ) () - let get_all_bonds _ dbg ?(from_cache=false) () = + let get_all_bonds dbg from_cache = Debug.with_thread_associated dbg (fun () -> if from_cache then let ports = List.concat (List.map (fun (_, {ports}) -> ports) !config.bridge_config) in @@ -858,8 +859,16 @@ module Bridge = struct | Bridge -> raise Not_implemented - let add_port _ dbg ?bond_mac ~bridge ~name ~interfaces ?(bond_properties=[]) ?(kind=Basic) () = + let add_port dbg bond_mac bridge name interfaces bond_properties kind = Debug.with_thread_associated dbg (fun () -> + let bond_properties = match bond_properties with + | Some l -> l + | None -> [] + in + let kind = match kind with + | Some v -> v + | None -> Basic_port + in let config = get_config bridge in let ports = if List.mem_assoc name config.ports then @@ -876,11 +885,11 @@ module Bridge = struct (String.concat ", " interfaces) (match bond_mac with Some mac -> " and MAC " ^ mac | None -> ""); match kind with - | Basic -> add_basic_port dbg bridge name port + | Basic_port -> add_basic_port dbg bridge name port | PVS_proxy -> add_pvs_proxy_port dbg bridge name port ) () - let remove_port _ dbg ~bridge ~name = + let remove_port dbg bridge name = Debug.with_thread_associated dbg (fun () -> debug "Removing port %s from bridge %s" name bridge; let config = get_config bridge in @@ -895,7 +904,7 @@ module Bridge = struct ignore (Brctl.destroy_port bridge name) ) () - let get_interfaces _ dbg ~name = + let get_interfaces dbg name = Debug.with_thread_associated dbg (fun () -> match !backend_kind with | Openvswitch -> @@ -904,7 +913,7 @@ module Bridge = struct Sysfs.bridge_to_interfaces name ) () - let get_physical_interfaces _ dbg ~name = + let get_physical_interfaces dbg name = Debug.with_thread_associated dbg (fun () -> match !backend_kind with | Openvswitch -> @@ -946,13 +955,13 @@ module Bridge = struct (get_config name).persistent_b ) () - let set_persistent _ dbg ~name ~value = + let set_persistent dbg name value = Debug.with_thread_associated dbg (fun () -> debug "Making bridge %s %spersistent" name (if value then "" else "non-"); update_config name {(get_config name) with persistent_b = value} ) () - let make_config _ dbg ?(conservative=false) ~config () = + let make_config dbg conservative config = Debug.with_thread_associated dbg (fun () -> let vlans_go_last (_, {vlan=vlan_of_a}) (_, {vlan=vlan_of_b}) = if vlan_of_a = None && vlan_of_b = None then 0 @@ -976,7 +985,7 @@ module Bridge = struct (String.concat ", " (List.map (fun (name, _) -> name) vlan_parents)); let config = vlan_parents @ persistent_config in (* Do not try to recreate bridges that already exist *) - let current = get_all () dbg () in + let current = get_all dbg () in List.filter (function (name, _) -> not (List.mem name current)) config end else config @@ -989,20 +998,21 @@ module Bridge = struct List.iter (function (bridge_name, ({ports; vlan; bridge_mac; igmp_snooping; other_config; _} as c)) -> update_config bridge_name c; exec (fun () -> - create () dbg ?vlan ?mac:bridge_mac ?igmp_snooping ~other_config ~name:bridge_name (); + create dbg vlan bridge_mac igmp_snooping (Some other_config) bridge_name; List.iter (fun (port_name, {interfaces; bond_properties; bond_mac; kind}) -> - add_port () dbg ?bond_mac ~bridge:bridge_name ~name:port_name ~interfaces ~bond_properties ~kind () - ) ports + add_port dbg bond_mac bridge_name port_name interfaces (Some bond_properties) (Some kind)) ports ) ) config ) () end +module S = Network_interface.Interface_API(Idl.GenServerExn ()) + module PVS_proxy = struct - open PVS_proxy + open S.PVS_proxy + + let path = ref "/opt/citrix/pvsproxy/socket/pvsproxy" - let path = ref "/opt/citrix/pvsproxy/socket/pvsproxy" - let do_call call = try Jsonrpc_client.with_rpc ~path:!path ~call () @@ -1010,15 +1020,15 @@ module PVS_proxy = struct error "Error when calling PVS proxy: %s" (Printexc.to_string e); raise PVS_proxy_connection_error - let configure_site _ dbg config = + let configure_site dbg config = debug "Configuring PVS proxy for site %s" config.site_uuid; - let call = {Rpc.name = "configure_site"; params = [rpc_of_t config]} in + let call = {Rpc.name = "configure_site"; params = [Rpcmarshal.marshal t.ty config]} in let _ = do_call call in () - let remove_site _ dbg uuid = + let remove_site dbg uuid = debug "Removing PVS proxy for site %s" uuid; - let call = Rpc.{name = "remove_site"; params = [Dict ["site_uuid", rpc_of_string uuid]]} in + let call = Rpc.{name = "remove_site"; params = [Dict ["site_uuid", Rpcmarshal.marshal Rpc.Types.string.ty uuid]]} in let _ = do_call call in () end @@ -1045,8 +1055,8 @@ let on_startup () = remove_centos_config (); if !backend_kind = Openvswitch then Ovs.set_max_idle 5000; - Bridge.make_config () dbg ~conservative:true ~config:!config.bridge_config (); - Interface.make_config () dbg ~conservative:true ~config:!config.interface_config (); + Bridge.make_config dbg true !config.bridge_config; + Interface.make_config dbg true !config.interface_config; (* If there is still a network.dbcache file, move it out of the way. *) if (try Unix.access (Filename.concat "/var/lib/xcp" "network.dbcache") [Unix.F_OK]; true with _ -> false) then Unix.rename (Filename.concat "/var/lib/xcp" "network.dbcache") (Filename.concat "/var/lib/xcp" "network.dbcache.bak"); diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 5aed37376..1dd3476c4 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -18,7 +18,6 @@ open Network_utils module D = Debug.Make(struct let name = "networkd" end) open D -module Server = Network_interface.Server(Network_server) let resources = [ { Xcp_service.name = "network-conf"; @@ -87,6 +86,45 @@ let doc = String.concat "\n" [ "This service looks after host network configuration, including setting up bridges and/or openvswitch instances, configuring IP addresses etc."; ] + +let bind () = + let open Network_server in + S.clear_state clear_state; + S.reset_state reset_state; + S.set_gateway_interface set_gateway_interface; + S.set_dns_interface set_dns_interface; + S.Interface.get_all Interface.get_all; + S.Interface.exists Interface.exists; + S.Interface.get_mac Interface.get_mac; + S.Interface.is_up Interface.is_up; + S.Interface.get_ipv4_addr Interface.get_ipv4_addr; + S.Interface.set_ipv4_conf Interface.set_ipv4_conf; + S.Interface.get_ipv4_gateway Interface.get_ipv4_gateway; + S.Interface.get_ipv6_addr Interface.get_ipv6_addr; + S.Interface.get_dns Interface.get_dns; + S.Interface.get_mtu Interface.get_mtu; + S.Interface.get_capabilities Interface.get_capabilities; + S.Interface.is_connected Interface.is_connected; + S.Interface.is_physical Interface.is_physical; + S.Interface.has_vlan Interface.has_vlan; + S.Interface.bring_down Interface.bring_down; + S.Interface.set_persistent Interface.set_persistent; + S.Interface.make_config Interface.make_config; + S.Bridge.get_all Bridge.get_all; + S.Bridge.create Bridge.create; + S.Bridge.destroy Bridge.destroy; + S.Bridge.get_kind Bridge.get_kind; + S.Bridge.get_all_ports Bridge.get_all_ports; + S.Bridge.get_all_bonds Bridge.get_all_bonds; + S.Bridge.set_persistent Bridge.set_persistent; + S.Bridge.add_port Bridge.add_port; + S.Bridge.remove_port Bridge.remove_port; + S.Bridge.get_interfaces Bridge.get_interfaces; + S.Bridge.get_physical_interfaces Bridge.get_physical_interfaces; + S.Bridge.make_config Bridge.make_config; + S.PVS_proxy.configure_site PVS_proxy.configure_site; + S.PVS_proxy.remove_site PVS_proxy.remove_site + let _ = Coverage.init "networkd"; begin match Xcp_service.configure2 @@ -99,10 +137,11 @@ let _ = exit 1 end; + bind (); let server = Xcp_service.make ~path:!Network_interface.default_path ~queue_name:!Network_interface.queue_name - ~rpc_fn:(Server.process ()) + ~rpc_fn:(Idl.server Network_server.S.implementation) () in Xcp_service.maybe_daemonize ~start_fn:(fun () -> From 540b7b22ac2c7fe7774ccc38a38dcbb6eab41ce5 Mon Sep 17 00:00:00 2001 From: Yang Qian Date: Thu, 22 Feb 2018 11:46:42 +0800 Subject: [PATCH 170/260] Convert configuration file to adapt `ipv4_route` structure changes Signed-off-by: Yang Qian --- lib/network_config.ml | 47 +++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 45 insertions(+), 2 deletions(-) diff --git a/lib/network_config.ml b/lib/network_config.ml index 479598d00..d7318d896 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -113,12 +113,55 @@ let write_config config = (Printexc.to_string e) (Printexc.get_backtrace ()); raise Write_error +(* Porting network interaface to ppx: convert ipv4_routes from (string * int * string) list to {gateway:string; netmask:int; subnet:string} *) +let convert_configuration cfg = + let open Yojson.Safe in + let convert_ipv4_routes cfg = + let convert_ipv4_route cfg = + match cfg with + | `List [`String gateway; `Int netmask; `String subnet] -> + debug "convert ipv4 route"; + `Assoc ["gateway", `String gateway; "netmask", `Int netmask; "subnet", `String subnet] + | other -> other + in + match cfg with + | `List l -> + `List (List.map convert_ipv4_route l) + | other -> other + in + let convert_interface_item cfg = + match cfg with + | `Assoc l -> + `Assoc (List.map (fun (k, v) -> + let v = if k = "ipv4_routes" then convert_ipv4_routes v else v in + k, v + ) l) + | other -> other + in + let convert_interface_config cfg = + match cfg with + | `Assoc l -> + `Assoc (List.map (fun (k, v) -> k, convert_interface_item v) l) + | other -> other + in + let json = match from_string cfg with + | `Assoc l -> + `Assoc (List.map (fun (k, v) -> + let v = if k = "interface_config" then convert_interface_config v else v in + k, v + ) l) + | other -> other + in + to_string json + let read_config () = try - let config_json = Xapi_stdext_unix.Unixext.string_of_file config_file_path in + let config_json = Xapi_stdext_unix.Unixext.string_of_file config_file_path |> convert_configuration in match config_json |> Jsonrpc.of_string |> Rpcmarshal.unmarshal typ_of_config_t with | Result.Ok v -> v - | Result.Error e -> raise Read_error + | Result.Error (`Msg err_msg) -> + error "Read configuration error: %s" err_msg; + raise Read_error with | Unix.Unix_error (Unix.ENOENT, _, file) -> info "Cannot read networkd configuration file %s because it does not exist." file; From 56102f751b3bdad16f9892e30b90ecfa6bfd28f8 Mon Sep 17 00:00:00 2001 From: Wei Xie Date: Fri, 12 Jan 2018 18:10:34 +0800 Subject: [PATCH 171/260] Add stub functions Signed-off-by: Wei Xie --- networkd/network_server.ml | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 5a288d6d7..eef1b1d52 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -1007,6 +1007,27 @@ module Bridge = struct end module S = Network_interface.Interface_API(Idl.GenServerExn ()) +module Sriov = struct + open Xcp_pci + + let enable _ dbg ~name = + Debug.with_thread_associated dbg (fun () -> + debug "Enable NET-SRIOV by name: %s" name; + Ok Modprobe_successful + ) () + + let disable _ dbg ~name = + Debug.with_thread_associated dbg (fun () -> + debug "Disable NET-SRIOV by name: %s" name; + Ok Modprobe_successful + ) () + + let make_vf_config _ dbg ~pci_address ~vf_info = + Debug.with_thread_associated dbg (fun () -> + let pcibuspath = string_of_address pci_address in + debug "Config VF with pci address: %s" pcibuspath; + ) () +end module PVS_proxy = struct open S.PVS_proxy From 0b56af0283b33f6c7829b0ebb110f35170a3e5f9 Mon Sep 17 00:00:00 2001 From: Yang Qian Date: Tue, 16 Jan 2018 13:13:59 +0800 Subject: [PATCH 172/260] CP-26333 Implement Network.Interface.get_pci_bus_path Implement interface to get pci bus path for device underneath PIF Signed-off-by: Yang Qian --- networkd/network_server.ml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index eef1b1d52..6ef2eea09 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -141,6 +141,10 @@ module Interface = struct | Some master -> Proc.get_bond_slave_mac master name | None -> Ip.get_mac name ) () + let get_pci_bus_path _ dbg ~name = + Debug.with_thread_associated dbg (fun () -> + Sysfs.get_pcibuspath name + ) () let is_up dbg name = Debug.with_thread_associated dbg (fun () -> From 154c240338c70c0dbc4dab425a9f7ecd2316441d Mon Sep 17 00:00:00 2001 From: Wei Xie Date: Fri, 26 Jan 2018 13:25:59 +0800 Subject: [PATCH 173/260] Add more functions in Sysfs module and Ip module to support SRIOV. - Use Rresult style in networkd and define util_error that might occur in Networkd Signed-off-by: Wei Xie --- lib/jbuild | 1 + lib/network_utils.ml | 84 +++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 84 insertions(+), 1 deletion(-) diff --git a/lib/jbuild b/lib/jbuild index 719f2f191..372840d24 100644 --- a/lib/jbuild +++ b/lib/jbuild @@ -8,6 +8,7 @@ rpclib systemd threads + re.perl xapi-stdext-unix xcp-inventory xcp.network)) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index d41d2e6c0..e6314ef94 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -13,7 +13,8 @@ *) open Xapi_stdext_pervasives - +open Xapi_stdext_unix +open Xapi_stdext_std open Network_interface module D = Debug.Make(struct let name = "network_utils" end) @@ -26,6 +27,20 @@ exception Not_implemented exception Vlan_in_use of (string * int) exception PVS_proxy_connection_error +type util_error = +| Bus_out_of_range +| Not_enough_mmio_resources +| Fail_to_set_vf_rate +| Fail_to_set_vf_vlan +| Fail_to_set_vf_mac +| Parent_device_of_vf_not_found +| Vf_index_not_found +| Fail_to_rebuild_initrd +| Fail_to_write_modprobe_cfg +| Fail_to_get_driver_name +| No_sriov_capability +| Other + let iproute2 = "/sbin/ip" let resolv_conf = "/etc/resolv.conf" let dhclient = "/sbin/dhclient" @@ -171,6 +186,11 @@ module Sysfs = struct debug "%s: could not read netdev's driver name" dev; None + let get_driver_name_err dev = + match get_driver_name dev with + | Some a -> Result.Ok a + | None -> Result.Error (Fail_to_get_driver_name, "Failed to get driver name for: "^ dev) + (** Returns the features bitmap for the driver for [dev]. * The features bitmap is a set of NETIF_F_ flags supported by its driver. *) let get_features dev = @@ -215,6 +235,68 @@ module Sysfs = struct |> (fun p -> try read_one_line p |> duplex_of_string with _ -> Duplex_unknown) in (speed, duplex) + let get_dev_nums_with_same_driver driver = + try + Sys.readdir ("/sys/bus/pci/drivers/" ^ driver) + |> Array.to_list + |> List.filter (Re.execp (Re_perl.compile_pat "\d+:\d+:\d+\.\d+")) + |> List.length + with _ -> 0 + + let parent_device_of_vf pcibuspath = + try + let pf_net_path = Printf.sprintf "/sys/bus/pci/devices/%s/physfn/net" pcibuspath in + let devices = Sys.readdir pf_net_path in + Result.Ok devices.(0) + with _ -> Result.Error (Parent_device_of_vf_not_found, "Can not get parent device for " ^ pcibuspath) + + let device_index_of_vf parent_device pcibuspath = + try + let re = Re_perl.compile_pat "virtfn(\d+)" in + let device_path = getpath parent_device "device" in + let group = Sys.readdir device_path + |> Array.to_list + |> List.filter (Re.execp re) (* List elements are like "virtfn1" *) + |> List.find (fun x -> Xstringext.String.has_substr (Unix.readlink (device_path ^ "/" ^ x)) pcibuspath ) + |> Re.exec_opt re + in + match group with + | None -> Result.Error (Vf_index_not_found, "Can not get device index for " ^ pcibuspath) + | Some x -> Ok (int_of_string (Re.Group.get x 1)) + with _ -> Result.Error (Vf_index_not_found, "Can not get device index for " ^ pcibuspath) + + let get_sriov_numvfs dev = + try + getpath dev "device/sriov_numvfs" + |> read_one_line + |> String.trim + |> int_of_string + with _ -> 0 + + let get_sriov_maxvfs dev = + try + getpath dev "device/sriov_totalvfs" + |> read_one_line + |> String.trim + |> int_of_string + |> fun n -> n - 1 (* maxvfs is totalvfs -1, as totalvfs is PF num + VF num *) + with _ -> 0 + + let set_sriov_numvfs dev num_vfs = + let interface = getpath dev "device/sriov_numvfs" in + let oc = open_out interface in + try + write_one_line interface (string_of_int num_vfs); + if get_sriov_numvfs dev = num_vfs then Result.Ok () + else Result.Error (Other, "Error: set SR-IOV error on " ^ dev) + with + | Sys_error s when Xstringext.String.has_substr s "out of range of" -> + Result.Error (Bus_out_of_range, "Error: bus out of range when setting SR-IOV numvfs on " ^ dev) + | Sys_error s when Xstringext.String.has_substr s "not enough MMIO resources" -> + Result.Error (Not_enough_mmio_resources, "Error: not enough mmio resources when setting SR-IOV numvfs on " ^ dev) + | e -> + let msg = Printf.sprintf "Error: set SR-IOV numvfs error with exception %s on %s" (Printexc.to_string e) dev in + Result.Error (Other, msg) end module Ip = struct From f902ce60fb21cd0d2fbdda95a6254ba5d9ed45b8 Mon Sep 17 00:00:00 2001 From: Wei Xie Date: Fri, 26 Jan 2018 13:28:24 +0800 Subject: [PATCH 174/260] Add support for getting SRIOV capabilities. Signed-off-by: Wei Xie --- networkd/network_server.ml | 30 ++++++------------------------ 1 file changed, 6 insertions(+), 24 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 6ef2eea09..e970c91c0 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -118,6 +118,11 @@ let need_enic_workaround () = | Some vs -> (is_older_version vs !enic_workaround_until_version ()) | None -> false ) +module Sriov = struct + let get_capabilities dev = + if Sysfs.get_sriov_maxvfs dev = 0 then [] else ["sriov"] +end + module Interface = struct let get_config name = get_config !config.interface_config default_interface name @@ -372,7 +377,7 @@ module Interface = struct let get_capabilities dbg name = Debug.with_thread_associated dbg (fun () -> - Fcoe.get_capabilities name + Fcoe.get_capabilities name @ Sriov.get_capabilities name ) () let is_connected dbg name = @@ -1010,29 +1015,6 @@ module Bridge = struct ) () end -module S = Network_interface.Interface_API(Idl.GenServerExn ()) -module Sriov = struct - open Xcp_pci - - let enable _ dbg ~name = - Debug.with_thread_associated dbg (fun () -> - debug "Enable NET-SRIOV by name: %s" name; - Ok Modprobe_successful - ) () - - let disable _ dbg ~name = - Debug.with_thread_associated dbg (fun () -> - debug "Disable NET-SRIOV by name: %s" name; - Ok Modprobe_successful - ) () - - let make_vf_config _ dbg ~pci_address ~vf_info = - Debug.with_thread_associated dbg (fun () -> - let pcibuspath = string_of_address pci_address in - debug "Config VF with pci address: %s" pcibuspath; - ) () -end - module PVS_proxy = struct open S.PVS_proxy From 35353ffb81b648606e7edfa009ce836fd44f9f48 Mon Sep 17 00:00:00 2001 From: Wei Xie Date: Fri, 26 Jan 2018 13:30:34 +0800 Subject: [PATCH 175/260] Add support for enabling SRIOV. - Add Dracut module - Add Modprobe module - First try Sysfs to enable SRIOV, and if not supported then try Modprobe. Signed-off-by: Wei Xie --- lib/network_utils.ml | 24 ++++++++ networkd/network_server.ml | 122 +++++++++++++++++++++++++++++++++++++ networkd/networkd.ml | 3 + 3 files changed, 149 insertions(+) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index e6314ef94..01e356857 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -53,6 +53,9 @@ let brctl = ref "/sbin/brctl" let modprobe = "/sbin/modprobe" let ethtool = ref "/sbin/ethtool" let bonding_dir = "/proc/net/bonding/" +let uname = ref "/usr/bin/uname" +let dracut = ref "/sbin/dracut" +let dracut_timeout = ref 120.0 let fcoedriver = ref "/opt/xensource/libexec/fcoe_driver" let inject_igmp_query_script = ref "/usr/libexec/xenopsd/igmp_query_injector.py" let mac_table_size = ref 10000 @@ -1252,3 +1255,24 @@ module Ethtool = struct if options <> [] then ignore (call ~log:true ("-K" :: name :: (List.concat (List.map (fun (k, v) -> [k; v]) options)))) end + +module Dracut = struct + let call ?(log=false) args = + call_script ~timeout:(Some !dracut_timeout) ~log_successful_output:log !dracut args + + let rebuild_initrd () = + try + info "Building initrd..."; + let img_name = call_script !uname ["-r"] |> String.trim in + call ["-f"; Printf.sprintf "/boot/initrd-%s.img" img_name; img_name]; + Result.Ok () + with _ -> Result.Error (Fail_to_rebuild_initrd, "Error occurs in building initrd") +end + +module Modprobe = struct + let write_conf_file driver content= + try + Unixext.write_string_to_file (Printf.sprintf "/etc/modprobe.d/%s.conf" driver) (String.concat "\n" content); + Result.Ok () + with _ -> Result.Error (Fail_to_write_modprobe_cfg, "Failed to write modprobe configuration file for: " ^ driver) +end diff --git a/networkd/network_server.ml b/networkd/network_server.ml index e970c91c0..ea6a48c9f 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -14,6 +14,9 @@ open Network_utils open Network_interface +open Xapi_stdext_std +open Xapi_stdext_unix +open Xapi_stdext_monadic module D = Debug.Make(struct let name = "network_server" end) open D @@ -121,6 +124,125 @@ let need_enic_workaround () = module Sriov = struct let get_capabilities dev = if Sysfs.get_sriov_maxvfs dev = 0 then [] else ["sriov"] + + (* To enable SR-IOV via modprobe configuration, we add a line like `options igb max_vfs=7,7,7` + into the configuration. This function is meant to generate the options like `7,7,7`. the `7` have to + be repeated as many times as the number of devices with the same driver. + *) + let gen_options_for_maxvfs driver max_vfs = + match Sysfs.get_dev_nums_with_same_driver driver with + | num when num > 0 -> Result.Ok ( + Array.make num (string_of_int max_vfs) + |> Array.to_list + |> String.concat ",") + | _ -> Result.Error (Other, "Fail to generate options for maxvfs for " ^ driver) + + (* For given driver like igb, we parse each line of igb.conf which is the modprobe + configuration for igb. We keep the same the lines that do not have SR-IOV configurations and + change lines that need to be changed with patterns like `options igb max_vfs=4` + *) + let parse_modprobe_conf_internal file_path driver option = + let has_probe_conf = ref false in + let need_rebuild_initrd = ref false in + let parse_single_line s = + let parse_driver_options s = + match Xstringext.String.split ~limit:2 '=' s with + (* has SR-IOV configuration but the max_vfs is exactly what we want to set, so no changes and return s *) + | [k; v] when k = "max_vfs" && v = option -> has_probe_conf := true; s + (* has SR-IOV configuration and we need change it to expected option *) + | [k; v] when k = "max_vfs" -> + has_probe_conf := true; + need_rebuild_initrd := true; + debug "change SR-IOV options from [%s=%s] to [%s=%s]" k v k option; + Printf.sprintf "max_vfs=%s" option + (* we do not care the lines without SR-IOV configurations *) + | _ -> s + in + let trimed_s = String.trim s in + if Re.execp (Re_perl.compile_pat ("options[ \t]+" ^ driver)) trimed_s then + let driver_options = Re.split (Re_perl.compile_pat "[ \t]+") trimed_s in + List.map parse_driver_options driver_options + |> String.concat " " + else + trimed_s + in + let lines = try Unixext.read_lines file_path with _ -> [] in + let new_conf = List.map parse_single_line lines in + !has_probe_conf, !need_rebuild_initrd, new_conf + + (* + returns ( a * b * c) where + a indicates the probe configuration already has the max_vfs options, meaning the device doesn't support sysfs and will be configed by modprobe + b indicates some changes shall be made on the coniguration to enable SR-IOV to max_vfs, so we shall rebuild the initrd. + and c is the configurations after these changes + *) + let parse_modprobe_conf driver max_vfs = + try + let open Rresult.R.Infix in + let file_path = Printf.sprintf "/etc/modprobe.d/%s.conf" driver in + gen_options_for_maxvfs driver max_vfs >>= fun options -> + Result.Ok (parse_modprobe_conf_internal file_path driver options) + with _ -> Result.Error (Other, "Failed to parse modprobe conf for SR-IOV configuration for " ^ driver) + + let enable_sriov_via_modprobe driver maxvfs has_probe_conf need_rebuild_initrd conf = + let open Rresult.R.Infix in + match has_probe_conf, need_rebuild_initrd with + | true, true -> + Modprobe.write_conf_file driver conf >>= fun () -> + Dracut.rebuild_initrd () + | false, false -> + gen_options_for_maxvfs driver maxvfs >>= fun options -> + let new_option_line = Printf.sprintf "options %s max_vfs=%s" driver options in + Modprobe.write_conf_file driver (conf @ [new_option_line]) >>= fun () -> + Dracut.rebuild_initrd () + | true, false -> Result.Ok () (* already have modprobe configuration and no need to change *) + | false, true -> Result.Error (Other, "enabling SR-IOV via modprobe never comes here for: " ^ driver) + + let enable_internal dev = + let open Rresult.R.Infix in + let numvfs = Sysfs.get_sriov_numvfs dev + and maxvfs = Sysfs.get_sriov_maxvfs dev in + Sysfs.get_driver_name_err dev >>= fun driver -> + parse_modprobe_conf driver maxvfs >>= fun (has_probe_conf, need_rebuild_initrd, conf) -> + if maxvfs = 0 then Result.Error (No_sriov_capability, (Printf.sprintf "%s: do not have SR-IOV capabilities" dev)) else Ok () >>= fun () -> + (* We cannot first call sysfs method unconditionally for the case where the `SR-IOV hardware status` is ON and + we are about to enable SR-IOV, which is the else case. It is because sysfs method to enable SR-IOV on a `SR-IOV + already enabled device` will always be succuessful even if the device doesn't support sysfs. A simple example is as follows: + + - a device that doesn't support sysfs + - enable the device via modprobe -> Hardware Status OFF + - reboot -> Status ON + - disable via modprobe before reboot -> Status ON + - enable via sysfs -> will return Sysfs_succesfully -> Here bug arise.*) + if numvfs = 0 then begin + debug "enable SR-IOV on a device: %s that is disabled" dev; + match Sysfs.set_sriov_numvfs dev maxvfs with + | Result.Ok _ -> Ok Sysfs_successful + | Result.Error (Bus_out_of_range, msg) as e -> + debug "%s" msg; e + | Result.Error (Not_enough_mmio_resources, msg) as e -> + debug "%s" msg; e + | Result.Error (_, msg) -> + debug "%s does not support sysfs interfaces for reason %s, trying modprobe" dev msg; + enable_sriov_via_modprobe driver maxvfs has_probe_conf need_rebuild_initrd conf >>= fun () -> + Ok Modprobe_successful_requires_reboot + end + else begin + debug "enable SR-IOV on a device: %s that has been already enabled" dev; + match has_probe_conf with + | false -> Ok Sysfs_successful + | true -> + enable_sriov_via_modprobe driver maxvfs has_probe_conf need_rebuild_initrd conf >>= fun () -> + Ok Modprobe_successful + end + + let enable _ dbg ~name = + Debug.with_thread_associated dbg (fun () -> + debug "Enable network SR-IOV by name: %s" name; + match enable_internal name with + | Ok t -> (Ok t:enable_result) + | Result.Error (_, msg) -> Error msg + ) () end module Interface = struct diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 1dd3476c4..c9844e21e 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -60,6 +60,9 @@ let options = [ "igmp-query-maxresp-time", Arg.Set_string Network_utils.igmp_query_maxresp_time, (fun () -> !Network_utils.igmp_query_maxresp_time), "Maximum Response Time in IGMP Query message to send"; "enable-ipv6-mcast-snooping", Arg.Bool (fun x -> Network_utils.enable_ipv6_mcast_snooping := x), (fun () -> string_of_bool !Network_utils.enable_ipv6_mcast_snooping), "IPv6 multicast snooping toggle"; "mcast-snooping-disable-flood-unregistered", Arg.Bool (fun x -> Network_utils.mcast_snooping_disable_flood_unregistered := x), (fun () -> string_of_bool !Network_utils.mcast_snooping_disable_flood_unregistered), "Set OVS bridge configuration mcast-snooping-disable-flood-unregistered as 'true' or 'false'"; + "uname_cmd_path", Arg.Set_string Network_utils.uname, (fun () -> !Network_utils.uname), "Path to the Unix command uname"; + "dracut_cmd_path", Arg.Set_string Network_utils.dracut, (fun () -> !Network_utils.dracut), "Path to the Unix command dracut"; + "dracut_timeout", Arg.Set_float Network_utils.dracut_timeout, (fun () -> string_of_float !Network_utils.dracut_timeout), "Default value for the dracut command timeout"; ] let start server = From 591c7d49d731e28e281f2e2dc9a0ffe5a4b10335 Mon Sep 17 00:00:00 2001 From: Wei Xie Date: Fri, 26 Jan 2018 13:31:11 +0800 Subject: [PATCH 176/260] Add support for disabling SRIOV. Signed-off-by: Wei Xie --- networkd/network_server.ml | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index ea6a48c9f..b9ce47f70 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -243,6 +243,28 @@ module Sriov = struct | Ok t -> (Ok t:enable_result) | Result.Error (_, msg) -> Error msg ) () + + let disable_internal dev = + let open Rresult.R.Infix in + Sysfs.get_driver_name_err dev >>= + fun driver -> + parse_modprobe_conf driver 0 >>= + fun (has_probe_conf, need_rebuild_intrd, conf) -> + match has_probe_conf,need_rebuild_intrd with + | false, false -> + Sysfs.set_sriov_numvfs dev 0 + | true, true -> + Modprobe.write_conf_file driver conf >>= fun () -> + Dracut.rebuild_initrd () + | _ -> Ok () + + let disable _ dbg ~name = + Debug.with_thread_associated dbg (fun () -> + debug "Disable network SR-IOV by name: %s" name; + match disable_internal name with + | Ok () -> (Ok:disable_result) + | Result.Error (_, msg) -> Error msg + ) () end module Interface = struct From 3f4a41465026462cb0866c84c3ca84d7055eebda Mon Sep 17 00:00:00 2001 From: Wei Xie Date: Fri, 26 Jan 2018 13:31:34 +0800 Subject: [PATCH 177/260] Add support for SRIOV VFs configuration. Support: - MAC address configuration - VLAN configuration - Rate limiting configuration Signed-off-by: Wei Xie --- lib/network_utils.ml | 16 ++++++++++++++++ networkd/network_server.ml | 26 ++++++++++++++++++++++++++ 2 files changed, 42 insertions(+) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 01e356857..727a74fbc 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -488,6 +488,22 @@ info "Found at [ %s ]" (String.concat ", " (List.map string_of_int indices)); let destroy_vlan name = if List.mem name (Sysfs.list ()) then ignore (call ~log:true ["link"; "delete"; name]) + + let set_vf_mac dev index mac = + try + Result.Ok (link_set dev ["vf"; string_of_int index; "mac"; mac]) + with _ -> Result.Error (Fail_to_set_vf_mac, "Failed to set vf mac for: " ^ dev) + + let set_vf_vlan dev index vlan = + try + Result.Ok (link_set dev ["vf"; string_of_int index; "vlan"; string_of_int vlan]) + with _ -> Result.Error (Fail_to_set_vf_vlan, "Failed to set vf vlan for: " ^ dev) + + (* We know some NICs do not support config VF Rate, so will explicitly tell XAPI this error*) + let set_vf_rate dev index rate = + try + Result.Ok (link_set dev ["vf"; string_of_int index; "mac"; string_of_int rate]) + with _ -> Result.Error (Fail_to_set_vf_rate, "Failed to set vf rate for: " ^ dev) end module Linux_bonding = struct diff --git a/networkd/network_server.ml b/networkd/network_server.ml index b9ce47f70..3d81f4767 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -265,6 +265,32 @@ module Sriov = struct | Ok () -> (Ok:disable_result) | Result.Error (_, msg) -> Error msg ) () + + let make_vf_conf_internal pcibuspath mac vlan rate = + let exe_except_none f = function + | None -> Result.Ok () + | Some a -> f a + in + let open Rresult.R.Infix in + Sysfs.parent_device_of_vf pcibuspath >>= fun dev -> + Sysfs.device_index_of_vf dev pcibuspath >>= fun index -> + exe_except_none (Ip.set_vf_mac dev index) mac >>= fun () -> + exe_except_none (Ip.set_vf_vlan dev index) vlan >>= fun () -> + exe_except_none (Ip.set_vf_rate dev index) rate + + let make_vf_config _ dbg ~pci_address ~(vf_info : Sriov.sriov_pci_t)= + Debug.with_thread_associated dbg (fun () -> + let vlan = Opt.map Int64.to_int vf_info.vlan + and rate = Opt.map Int64.to_int vf_info.rate + and pcibuspath = Xcp_pci.string_of_address pci_address in + debug "Config VF with pci address: %s" pcibuspath; + match make_vf_conf_internal pcibuspath vf_info.mac vlan rate with + | Result.Ok () -> (Ok:config_result) + | Result.Error (Fail_to_set_vf_rate, msg) -> + debug "%s" msg; + Error Config_vf_rate_not_supported + | Result.Error (_, msg) -> debug "%s" msg; Error (Unknown msg) + ) () end module Interface = struct From 69dedce0af3d70cf05319f736d60e673ab41e47f Mon Sep 17 00:00:00 2001 From: Wei Xie Date: Thu, 22 Feb 2018 16:06:52 +0800 Subject: [PATCH 178/260] Use Astring instead of Xstring and fix whitespaces and format. Signed-off-by: Wei Xie --- lib/network_utils.ml | 4 ++-- networkd/network_server.ml | 14 ++++++-------- networkd/networkd.ml | 6 +++--- 3 files changed, 11 insertions(+), 13 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 727a74fbc..3df340277 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -293,9 +293,9 @@ module Sysfs = struct if get_sriov_numvfs dev = num_vfs then Result.Ok () else Result.Error (Other, "Error: set SR-IOV error on " ^ dev) with - | Sys_error s when Xstringext.String.has_substr s "out of range of" -> + | Sys_error s when Astring.String.is_infix ~affix:"out of range of" s -> Result.Error (Bus_out_of_range, "Error: bus out of range when setting SR-IOV numvfs on " ^ dev) - | Sys_error s when Xstringext.String.has_substr s "not enough MMIO resources" -> + | Sys_error s when Astring.String.is_infix ~affix:"not enough MMIO resources" s -> Result.Error (Not_enough_mmio_resources, "Error: not enough mmio resources when setting SR-IOV numvfs on " ^ dev) | e -> let msg = Printf.sprintf "Error: set SR-IOV numvfs error with exception %s on %s" (Printexc.to_string e) dev in diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 3d81f4767..0792c4b0f 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -125,9 +125,9 @@ module Sriov = struct let get_capabilities dev = if Sysfs.get_sriov_maxvfs dev = 0 then [] else ["sriov"] - (* To enable SR-IOV via modprobe configuration, we add a line like `options igb max_vfs=7,7,7` - into the configuration. This function is meant to generate the options like `7,7,7`. the `7` have to - be repeated as many times as the number of devices with the same driver. + (* To enable SR-IOV via modprobe configuration, we add a line like `options igb max_vfs=7,7,7` + into the configuration. This function is meant to generate the options like `7,7,7`. the `7` have to + be repeated as many times as the number of devices with the same driver. *) let gen_options_for_maxvfs driver max_vfs = match Sysfs.get_dev_nums_with_same_driver driver with @@ -138,7 +138,7 @@ module Sriov = struct | _ -> Result.Error (Other, "Fail to generate options for maxvfs for " ^ driver) (* For given driver like igb, we parse each line of igb.conf which is the modprobe - configuration for igb. We keep the same the lines that do not have SR-IOV configurations and + configuration for igb. We keep the same the lines that do not have SR-IOV configurations and change lines that need to be changed with patterns like `options igb max_vfs=4` *) let parse_modprobe_conf_internal file_path driver option = @@ -246,10 +246,8 @@ module Sriov = struct let disable_internal dev = let open Rresult.R.Infix in - Sysfs.get_driver_name_err dev >>= - fun driver -> - parse_modprobe_conf driver 0 >>= - fun (has_probe_conf, need_rebuild_intrd, conf) -> + Sysfs.get_driver_name_err dev >>= fun driver -> + parse_modprobe_conf driver 0 >>= fun (has_probe_conf, need_rebuild_intrd, conf) -> match has_probe_conf,need_rebuild_intrd with | false, false -> Sysfs.set_sriov_numvfs dev 0 diff --git a/networkd/networkd.ml b/networkd/networkd.ml index c9844e21e..0c9ef59d3 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -60,9 +60,9 @@ let options = [ "igmp-query-maxresp-time", Arg.Set_string Network_utils.igmp_query_maxresp_time, (fun () -> !Network_utils.igmp_query_maxresp_time), "Maximum Response Time in IGMP Query message to send"; "enable-ipv6-mcast-snooping", Arg.Bool (fun x -> Network_utils.enable_ipv6_mcast_snooping := x), (fun () -> string_of_bool !Network_utils.enable_ipv6_mcast_snooping), "IPv6 multicast snooping toggle"; "mcast-snooping-disable-flood-unregistered", Arg.Bool (fun x -> Network_utils.mcast_snooping_disable_flood_unregistered := x), (fun () -> string_of_bool !Network_utils.mcast_snooping_disable_flood_unregistered), "Set OVS bridge configuration mcast-snooping-disable-flood-unregistered as 'true' or 'false'"; - "uname_cmd_path", Arg.Set_string Network_utils.uname, (fun () -> !Network_utils.uname), "Path to the Unix command uname"; - "dracut_cmd_path", Arg.Set_string Network_utils.dracut, (fun () -> !Network_utils.dracut), "Path to the Unix command dracut"; - "dracut_timeout", Arg.Set_float Network_utils.dracut_timeout, (fun () -> string_of_float !Network_utils.dracut_timeout), "Default value for the dracut command timeout"; + "uname-cmd-path", Arg.Set_string Network_utils.uname, (fun () -> !Network_utils.uname), "Path to the Unix command uname"; + "dracut-cmd-path", Arg.Set_string Network_utils.dracut, (fun () -> !Network_utils.dracut), "Path to the Unix command dracut"; + "dracut-timeout", Arg.Set_float Network_utils.dracut_timeout, (fun () -> string_of_float !Network_utils.dracut_timeout), "Default value for the dracut command timeout"; ] let start server = From 8200c521b5197bca781f102b6882879038eadba3 Mon Sep 17 00:00:00 2001 From: Wei Xie Date: Thu, 22 Feb 2018 16:09:14 +0800 Subject: [PATCH 179/260] CP-26856: unbind VFs from drivers before disable SR-IOV Signed-off-by: Wei Xie --- lib/network_utils.ml | 54 +++++++++++++++++++++++++++++++++----- networkd/network_server.ml | 1 + 2 files changed, 48 insertions(+), 7 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 3df340277..46a32c494 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -39,6 +39,8 @@ type util_error = | Fail_to_write_modprobe_cfg | Fail_to_get_driver_name | No_sriov_capability +| Vf_sysfs_path_not_found +| Fail_to_unbind_from_driver | Other let iproute2 = "/sbin/ip" @@ -253,21 +255,59 @@ module Sysfs = struct Result.Ok devices.(0) with _ -> Result.Error (Parent_device_of_vf_not_found, "Can not get parent device for " ^ pcibuspath) - let device_index_of_vf parent_device pcibuspath = + let get_child_vfs_sysfs_paths dev = try - let re = Re_perl.compile_pat "virtfn(\d+)" in - let device_path = getpath parent_device "device" in - let group = Sys.readdir device_path + let device_path = getpath dev "device" in + Result. Ok ( + Sys.readdir device_path |> Array.to_list - |> List.filter (Re.execp re) (* List elements are like "virtfn1" *) - |> List.find (fun x -> Xstringext.String.has_substr (Unix.readlink (device_path ^ "/" ^ x)) pcibuspath ) - |> Re.exec_opt re + |> List.filter (Re.execp (Re_perl.compile_pat "virtfn(\d+)")) (* List elements are like "virtfn1" *) + |> List.map (Filename.concat device_path) + ) + with _ -> Result.Error (Vf_sysfs_path_not_found, "Can not get child vfs sysfs paths for " ^ dev) + + let device_index_of_vf parent_dev pcibuspath = + try + let open Rresult.R.Infix in + get_child_vfs_sysfs_paths parent_dev >>= fun paths -> + let group = + List.find (fun x -> Astring.String.is_infix ~affix:pcibuspath (Unix.readlink x)) paths + |> Re.exec_opt (Re_perl.compile_pat "virtfn(\d+)") in match group with | None -> Result.Error (Vf_index_not_found, "Can not get device index for " ^ pcibuspath) | Some x -> Ok (int_of_string (Re.Group.get x 1)) with _ -> Result.Error (Vf_index_not_found, "Can not get device index for " ^ pcibuspath) + let unbind_child_vfs dev = + let open Rresult.R.Infix in + let unbind vf_path = + let driver_name = + try + Unix.readlink (Filename.concat vf_path "driver") + |> Filename.basename + with _ -> "" + and vf_pcibuspath = + Unix.readlink vf_path + |> Filename.basename + in + if driver_name = "" then Result.Ok () (* not bind to any driver, Ok *) + else begin + debug "unbinding %s from driver %s at %s" vf_path driver_name vf_pcibuspath; + let unbind_interface = Filename.concat vf_path "driver/unbind" + and remove_slot_interface = Filename.concat vf_path "driver/remove_slot" in + begin try + write_one_line remove_slot_interface vf_pcibuspath + with _ -> () + end; + try + write_one_line unbind_interface vf_pcibuspath; Result.Ok () + with _ -> Result.Error (Fail_to_unbind_from_driver, Printf.sprintf "%s: VF Fail to be unbound from driver %s" vf_path driver_name) + end + in + get_child_vfs_sysfs_paths dev >>= fun paths -> + List.fold_left (>>=) (Ok ()) (List.map (fun x -> fun _ -> unbind x) paths) + let get_sriov_numvfs dev = try getpath dev "device/sriov_numvfs" diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 0792c4b0f..9e38c4106 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -250,6 +250,7 @@ module Sriov = struct parse_modprobe_conf driver 0 >>= fun (has_probe_conf, need_rebuild_intrd, conf) -> match has_probe_conf,need_rebuild_intrd with | false, false -> + Sysfs.unbind_child_vfs dev >>= fun _ -> Sysfs.set_sriov_numvfs dev 0 | true, true -> Modprobe.write_conf_file driver conf >>= fun () -> From bf4f4e68eb2a547f0d5d8ef36001ea577b5a9e95 Mon Sep 17 00:00:00 2001 From: Yang Qian Date: Thu, 1 Mar 2018 16:56:02 +0800 Subject: [PATCH 180/260] Port sriov to ppx Signed-off-by: Yang Qian --- networkd/network_server.ml | 13 ++++++++----- networkd/networkd.ml | 6 +++++- 2 files changed, 13 insertions(+), 6 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 9e38c4106..0277c3a80 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -18,6 +18,7 @@ open Xapi_stdext_std open Xapi_stdext_unix open Xapi_stdext_monadic +module S = Network_interface.Interface_API(Idl.GenServerExn ()) module D = Debug.Make(struct let name = "network_server" end) open D @@ -122,7 +123,9 @@ let need_enic_workaround () = | None -> false ) module Sriov = struct - let get_capabilities dev = + open S.Sriov + + let get_capabilities dev = if Sysfs.get_sriov_maxvfs dev = 0 then [] else ["sriov"] (* To enable SR-IOV via modprobe configuration, we add a line like `options igb max_vfs=7,7,7` @@ -236,7 +239,7 @@ module Sriov = struct Ok Modprobe_successful end - let enable _ dbg ~name = + let enable dbg name = Debug.with_thread_associated dbg (fun () -> debug "Enable network SR-IOV by name: %s" name; match enable_internal name with @@ -257,7 +260,7 @@ module Sriov = struct Dracut.rebuild_initrd () | _ -> Ok () - let disable _ dbg ~name = + let disable dbg name = Debug.with_thread_associated dbg (fun () -> debug "Disable network SR-IOV by name: %s" name; match disable_internal name with @@ -277,7 +280,7 @@ module Sriov = struct exe_except_none (Ip.set_vf_vlan dev index) vlan >>= fun () -> exe_except_none (Ip.set_vf_rate dev index) rate - let make_vf_config _ dbg ~pci_address ~(vf_info : Sriov.sriov_pci_t)= + let make_vf_config dbg pci_address (vf_info : sriov_pci_t) = Debug.with_thread_associated dbg (fun () -> let vlan = Opt.map Int64.to_int vf_info.vlan and rate = Opt.map Int64.to_int vf_info.rate @@ -315,7 +318,7 @@ module Interface = struct | Some master -> Proc.get_bond_slave_mac master name | None -> Ip.get_mac name ) () - let get_pci_bus_path _ dbg ~name = + let get_pci_bus_path dbg name = Debug.with_thread_associated dbg (fun () -> Sysfs.get_pcibuspath name ) () diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 0c9ef59d3..7115787fe 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -99,6 +99,7 @@ let bind () = S.Interface.get_all Interface.get_all; S.Interface.exists Interface.exists; S.Interface.get_mac Interface.get_mac; + S.Interface.get_pci_bus_path Interface.get_pci_bus_path; S.Interface.is_up Interface.is_up; S.Interface.get_ipv4_addr Interface.get_ipv4_addr; S.Interface.set_ipv4_conf Interface.set_ipv4_conf; @@ -126,7 +127,10 @@ let bind () = S.Bridge.get_physical_interfaces Bridge.get_physical_interfaces; S.Bridge.make_config Bridge.make_config; S.PVS_proxy.configure_site PVS_proxy.configure_site; - S.PVS_proxy.remove_site PVS_proxy.remove_site + S.PVS_proxy.remove_site PVS_proxy.remove_site; + S.Sriov.enable Sriov.enable; + S.Sriov.disable Sriov.disable; + S.Sriov.make_vf_config Sriov.make_vf_config let _ = Coverage.init "networkd"; From ab60463b6617107474f7dbc1ad7fbca81d1f5233 Mon Sep 17 00:00:00 2001 From: Wei Xie Date: Mon, 5 Mar 2018 21:25:30 +0800 Subject: [PATCH 181/260] CP-26923: Simplify Networkd logic by adding comments in modprobe config file. For those drivers don't support sysfs interface. We add comments in modprobe config file to identify the VF param and max_vfs. When we enable SR-IOV, we first check the existence of VF param to determine using modprobe or sysfs. If it is a modprobe driver, we write the configuration into the config file. - Add a function to determine if the VF param is an array or not. - Read config from comments in driver config file. - Move config_sriov to Modprobe module. - Refine get_capabilities - Add modinfo module Signed-off-by: Wei Xie --- lib/network_utils.ml | 149 ++++++++++++++++++++++++++++++++-- networkd/network_server.ml | 162 ++++++++----------------------------- networkd/networkd.ml | 1 + 3 files changed, 177 insertions(+), 135 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 46a32c494..1350ee97c 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -38,6 +38,7 @@ type util_error = | Fail_to_rebuild_initrd | Fail_to_write_modprobe_cfg | Fail_to_get_driver_name +| Fail_to_get_maxvfs | No_sriov_capability | Vf_sysfs_path_not_found | Fail_to_unbind_from_driver @@ -57,6 +58,7 @@ let ethtool = ref "/sbin/ethtool" let bonding_dir = "/proc/net/bonding/" let uname = ref "/usr/bin/uname" let dracut = ref "/sbin/dracut" +let modinfo = ref "/sbin/modinfo" let dracut_timeout = ref 120.0 let fcoedriver = ref "/opt/xensource/libexec/fcoe_driver" let inject_igmp_query_script = ref "/usr/libexec/xenopsd/igmp_query_injector.py" @@ -318,12 +320,11 @@ module Sysfs = struct let get_sriov_maxvfs dev = try - getpath dev "device/sriov_totalvfs" + Ok (getpath dev "device/sriov_totalvfs" |> read_one_line |> String.trim - |> int_of_string - |> fun n -> n - 1 (* maxvfs is totalvfs -1, as totalvfs is PF num + VF num *) - with _ -> 0 + |> int_of_string) + with _ -> Error (Fail_to_get_maxvfs, "Failed to get maxvfs from sysfs interface for device: " ^ dev) let set_sriov_numvfs dev num_vfs = let interface = getpath dev "device/sriov_numvfs" in @@ -1325,10 +1326,146 @@ module Dracut = struct with _ -> Result.Error (Fail_to_rebuild_initrd, "Error occurs in building initrd") end +module Modinfo = struct + let call ?(log=false) args = + call_script ~log_successful_output:log !modinfo args + + let is_param_array driver param_name = + try + let out = call ["--parameter"; driver] + |> String.trim |> String.split_on_char '\n' + in + let re = Re_perl.compile_pat "\((.*)\)$" in + let has_array_of str = + match Re.exec_opt re str with + | None -> false + | Some x -> Re.Group.get x 1 |> Astring.String.is_infix ~affix:"array of" + in + Ok (List.exists (fun line -> + match Astring.String.cut ~sep:":" line with + | None -> false + | Some (param, description) -> String.trim param = param_name && has_array_of description + ) out + ) + with _ -> Error (Other, Printf.sprintf "Failed to determine if VF param of driver '%s' is an array" driver) +end + module Modprobe = struct - let write_conf_file driver content= + let getpath driver = + Printf.sprintf "/etc/modprobe.d/%s.conf" driver + + let write_conf_file driver content = try - Unixext.write_string_to_file (Printf.sprintf "/etc/modprobe.d/%s.conf" driver) (String.concat "\n" content); + Unixext.write_string_to_file (getpath driver) (String.concat "\n" content); Result.Ok () with _ -> Result.Error (Fail_to_write_modprobe_cfg, "Failed to write modprobe configuration file for: " ^ driver) + + (* + For a igb driver, the module config file will be at path `/etc/modprobe.d/igb.conf` + The module config file is like: + # VFs-param: max_vfs + # VFs-maxvfs-by-default: 7 + # VFs-maxvfs-by-user: + options igb max_vfs=7,7 + + Example of calls: + "igb" -> "VFs-param" -> Some "max_vfs" + "igb" -> "VFs-maxvfs-by-default" -> Some "7" + "igb" -> "VFs-maxvfs-by-user" -> None + "igb" -> "Not existed comments" -> None + *) + let get_config_from_comments driver = + try + let open Xapi_stdext_std.Listext in + Unixext.read_lines (getpath driver) + |> List.filter_map (fun x -> + let line = String.trim x in + if not (Astring.String.is_prefix ~affix:("# ") line) + then None + else + match Astring.String.cut ~sep:":" (Astring.String.with_range ~first:2 line) with + | None -> None + | Some (k, v) when String.trim k = "" || String.trim v = "" -> None + | Some (k, v) -> Some (String.trim k, String.trim v) + ) + with _ -> [] + + (* this function not returning None means that the driver doesn't suppport sysfs. + If a driver doesn't support sysfs, then we add VF_param into its driver modprobe + configuration. Therefore, from XAPI's perspective, if Modprobe.get_vf_param is + not None, the driver definitely should use modprobe other than sysfs, + and if Modprobe.get_vf_param is None, we just simple try sysfs. *) + let get_vf_param config = + try + Some (List.assoc "VFs-param" config) + with _ -> None + + let get_maxvfs driver config = + let get_default_maxvfs config = + try + Some (List.assoc "VFs-maxvfs-by-default" config |> int_of_string) + with _ -> None + in + let get_user_defined_maxvfs config = + try + Some (List.assoc "VFs-maxvfs-by-user" config |> int_of_string) + with _ -> None + in + match get_default_maxvfs config, get_user_defined_maxvfs config with + | Some a, None -> Result.Ok a + | Some a, Some b -> Result.Ok (min a b) (* If users also define a maxvfs, we will use the smaller one *) + | _ -> Result.Error (Fail_to_get_maxvfs, "Fail to get maxvfs for "^ driver) + + let config_sriov driver vf_param maxvfs = + let open Rresult.R.Infix in + Modinfo.is_param_array driver vf_param >>= fun is_array -> + (* To enable SR-IOV via modprobe configuration, we first determine if the driver requires + in the configuration an array like `options igb max_vfs=7,7,7,7` or a single value + like `options igb max_vfs=7`. If an array is required, this repeat times equals to + the number of devices with the same driver. + *) + let repeat = if is_array then Sysfs.get_dev_nums_with_same_driver driver else 1 in + begin + if repeat > 0 then Result.Ok ( + Array.make repeat (string_of_int maxvfs) + |> Array.to_list + |> String.concat ",") + else Result.Error (Other, "Fail to generate options for maxvfs for " ^ driver) + end >>= fun option -> + let need_rebuild_initrd = ref false in + let has_probe_conf = ref false in + let parse_single_line s = + let parse_driver_options s = + match Astring.String.cut ~sep:"=" s with + (* has SR-IOV configuration but the max_vfs is exactly what we want to set, so no changes and return s *) + | Some (k, v) when k = vf_param && v = option -> has_probe_conf := true; s + (* has SR-IOV configuration and we need change it to expected option *) + | Some (k, v) when k = vf_param -> + has_probe_conf := true; + need_rebuild_initrd := true; + debug "change SR-IOV options from [%s=%s] to [%s=%s]" k v k option; + Printf.sprintf "%s=%s" vf_param option + (* we do not care the lines without SR-IOV configurations *) + | _ -> s + in + let trimed_s = String.trim s in + if Re.execp (Re_perl.compile_pat ("options[ \t]+" ^ driver)) trimed_s then + let driver_options = Re.split (Re_perl.compile_pat "[ \t]+") trimed_s in + List.map parse_driver_options driver_options + |> String.concat " " + else + trimed_s + in + let lines = try Unixext.read_lines (getpath driver) with _ -> [] in + let new_conf = List.map parse_single_line lines in + match !has_probe_conf, !need_rebuild_initrd with + | true, true -> + write_conf_file driver new_conf >>= fun () -> + Dracut.rebuild_initrd () + | false, false -> + let new_option_line = Printf.sprintf "options %s %s=%s" driver vf_param option in + write_conf_file driver (new_conf @ [new_option_line]) >>= fun () -> + Dracut.rebuild_initrd () + | true, false -> Result.Ok () (* already have modprobe configuration and no need to change *) + | false, true -> Result.Error (Other, "enabling SR-IOV via modprobe never comes here for: " ^ driver) end diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 0277c3a80..3f8ef2bb8 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -125,147 +125,51 @@ let need_enic_workaround () = module Sriov = struct open S.Sriov - let get_capabilities dev = - if Sysfs.get_sriov_maxvfs dev = 0 then [] else ["sriov"] - - (* To enable SR-IOV via modprobe configuration, we add a line like `options igb max_vfs=7,7,7` - into the configuration. This function is meant to generate the options like `7,7,7`. the `7` have to - be repeated as many times as the number of devices with the same driver. - *) - let gen_options_for_maxvfs driver max_vfs = - match Sysfs.get_dev_nums_with_same_driver driver with - | num when num > 0 -> Result.Ok ( - Array.make num (string_of_int max_vfs) - |> Array.to_list - |> String.concat ",") - | _ -> Result.Error (Other, "Fail to generate options for maxvfs for " ^ driver) - - (* For given driver like igb, we parse each line of igb.conf which is the modprobe - configuration for igb. We keep the same the lines that do not have SR-IOV configurations and - change lines that need to be changed with patterns like `options igb max_vfs=4` - *) - let parse_modprobe_conf_internal file_path driver option = - let has_probe_conf = ref false in - let need_rebuild_initrd = ref false in - let parse_single_line s = - let parse_driver_options s = - match Xstringext.String.split ~limit:2 '=' s with - (* has SR-IOV configuration but the max_vfs is exactly what we want to set, so no changes and return s *) - | [k; v] when k = "max_vfs" && v = option -> has_probe_conf := true; s - (* has SR-IOV configuration and we need change it to expected option *) - | [k; v] when k = "max_vfs" -> - has_probe_conf := true; - need_rebuild_initrd := true; - debug "change SR-IOV options from [%s=%s] to [%s=%s]" k v k option; - Printf.sprintf "max_vfs=%s" option - (* we do not care the lines without SR-IOV configurations *) - | _ -> s - in - let trimed_s = String.trim s in - if Re.execp (Re_perl.compile_pat ("options[ \t]+" ^ driver)) trimed_s then - let driver_options = Re.split (Re_perl.compile_pat "[ \t]+") trimed_s in - List.map parse_driver_options driver_options - |> String.concat " " - else - trimed_s - in - let lines = try Unixext.read_lines file_path with _ -> [] in - let new_conf = List.map parse_single_line lines in - !has_probe_conf, !need_rebuild_initrd, new_conf - - (* - returns ( a * b * c) where - a indicates the probe configuration already has the max_vfs options, meaning the device doesn't support sysfs and will be configed by modprobe - b indicates some changes shall be made on the coniguration to enable SR-IOV to max_vfs, so we shall rebuild the initrd. - and c is the configurations after these changes - *) - let parse_modprobe_conf driver max_vfs = - try - let open Rresult.R.Infix in - let file_path = Printf.sprintf "/etc/modprobe.d/%s.conf" driver in - gen_options_for_maxvfs driver max_vfs >>= fun options -> - Result.Ok (parse_modprobe_conf_internal file_path driver options) - with _ -> Result.Error (Other, "Failed to parse modprobe conf for SR-IOV configuration for " ^ driver) - - let enable_sriov_via_modprobe driver maxvfs has_probe_conf need_rebuild_initrd conf = - let open Rresult.R.Infix in - match has_probe_conf, need_rebuild_initrd with - | true, true -> - Modprobe.write_conf_file driver conf >>= fun () -> - Dracut.rebuild_initrd () - | false, false -> - gen_options_for_maxvfs driver maxvfs >>= fun options -> - let new_option_line = Printf.sprintf "options %s max_vfs=%s" driver options in - Modprobe.write_conf_file driver (conf @ [new_option_line]) >>= fun () -> - Dracut.rebuild_initrd () - | true, false -> Result.Ok () (* already have modprobe configuration and no need to change *) - | false, true -> Result.Error (Other, "enabling SR-IOV via modprobe never comes here for: " ^ driver) - - let enable_internal dev = +let get_capabilities dev = + let open Rresult.R.Infix in + let maxvfs_modprobe = + Sysfs.get_driver_name_err dev >>= fun driver -> + Modprobe.get_config_from_comments driver + |> Modprobe.get_maxvfs driver + and maxvfs_sysfs = Sysfs.get_sriov_maxvfs dev in + let is_support = + match maxvfs_modprobe, maxvfs_sysfs with + | Ok v, _ -> v > 0 + | Error _ , Ok v -> v > 0 + | _ -> false + in + if is_support then ["sriov"] else [] + + let config_sriov ~enable dev = let open Rresult.R.Infix in - let numvfs = Sysfs.get_sriov_numvfs dev - and maxvfs = Sysfs.get_sriov_maxvfs dev in Sysfs.get_driver_name_err dev >>= fun driver -> - parse_modprobe_conf driver maxvfs >>= fun (has_probe_conf, need_rebuild_initrd, conf) -> - if maxvfs = 0 then Result.Error (No_sriov_capability, (Printf.sprintf "%s: do not have SR-IOV capabilities" dev)) else Ok () >>= fun () -> - (* We cannot first call sysfs method unconditionally for the case where the `SR-IOV hardware status` is ON and - we are about to enable SR-IOV, which is the else case. It is because sysfs method to enable SR-IOV on a `SR-IOV - already enabled device` will always be succuessful even if the device doesn't support sysfs. A simple example is as follows: - - - a device that doesn't support sysfs - - enable the device via modprobe -> Hardware Status OFF - - reboot -> Status ON - - disable via modprobe before reboot -> Status ON - - enable via sysfs -> will return Sysfs_succesfully -> Here bug arise.*) - if numvfs = 0 then begin - debug "enable SR-IOV on a device: %s that is disabled" dev; - match Sysfs.set_sriov_numvfs dev maxvfs with - | Result.Ok _ -> Ok Sysfs_successful - | Result.Error (Bus_out_of_range, msg) as e -> - debug "%s" msg; e - | Result.Error (Not_enough_mmio_resources, msg) as e -> - debug "%s" msg; e - | Result.Error (_, msg) -> - debug "%s does not support sysfs interfaces for reason %s, trying modprobe" dev msg; - enable_sriov_via_modprobe driver maxvfs has_probe_conf need_rebuild_initrd conf >>= fun () -> - Ok Modprobe_successful_requires_reboot - end - else begin - debug "enable SR-IOV on a device: %s that has been already enabled" dev; - match has_probe_conf with - | false -> Ok Sysfs_successful - | true -> - enable_sriov_via_modprobe driver maxvfs has_probe_conf need_rebuild_initrd conf >>= fun () -> - Ok Modprobe_successful - end + let config = Modprobe.get_config_from_comments driver in + match Modprobe.get_vf_param config with + | Some vf_param -> + debug "enable SR-IOV on a device: %s via modprobe" dev; + (if enable then Modprobe.get_maxvfs driver config else Ok 0) >>= fun numvfs -> + Modprobe.config_sriov driver vf_param numvfs >>= fun _ -> + Ok Modprobe_successful_requires_reboot + | None -> + debug "enable SR-IOV on a device: %s via sysfs" dev; + (if enable then Sysfs.get_sriov_maxvfs dev else Ok 0) >>= fun numvfs -> + Sysfs.set_sriov_numvfs dev numvfs >>= fun _ -> + Ok Sysfs_successful let enable dbg name = Debug.with_thread_associated dbg (fun () -> debug "Enable network SR-IOV by name: %s" name; - match enable_internal name with + match config_sriov ~enable:true name with | Ok t -> (Ok t:enable_result) - | Result.Error (_, msg) -> Error msg + | Result.Error (_, msg) -> warn "Failed to enable SR-IOV on %s with error: %s" name msg; Error msg ) () - let disable_internal dev = - let open Rresult.R.Infix in - Sysfs.get_driver_name_err dev >>= fun driver -> - parse_modprobe_conf driver 0 >>= fun (has_probe_conf, need_rebuild_intrd, conf) -> - match has_probe_conf,need_rebuild_intrd with - | false, false -> - Sysfs.unbind_child_vfs dev >>= fun _ -> - Sysfs.set_sriov_numvfs dev 0 - | true, true -> - Modprobe.write_conf_file driver conf >>= fun () -> - Dracut.rebuild_initrd () - | _ -> Ok () - let disable dbg name = Debug.with_thread_associated dbg (fun () -> debug "Disable network SR-IOV by name: %s" name; - match disable_internal name with - | Ok () -> (Ok:disable_result) - | Result.Error (_, msg) -> Error msg + match config_sriov ~enable:false name with + | Ok _ -> (Ok:disable_result) + | Result.Error (_, msg) -> warn "Failed to disable SR-IOV on %s with error: %s" name msg; Error msg ) () let make_vf_conf_internal pcibuspath mac vlan rate = diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 7115787fe..015b55529 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -63,6 +63,7 @@ let options = [ "uname-cmd-path", Arg.Set_string Network_utils.uname, (fun () -> !Network_utils.uname), "Path to the Unix command uname"; "dracut-cmd-path", Arg.Set_string Network_utils.dracut, (fun () -> !Network_utils.dracut), "Path to the Unix command dracut"; "dracut-timeout", Arg.Set_float Network_utils.dracut_timeout, (fun () -> string_of_float !Network_utils.dracut_timeout), "Default value for the dracut command timeout"; + "modinfo-cmd-path", Arg.Set_string Network_utils.modinfo, (fun () -> !Network_utils.modinfo), "Path to the Unix command modinfo"; ] let start server = From 19c45ea6f8dc443fec75f64409d3d842ac701fb9 Mon Sep 17 00:00:00 2001 From: Wei Xie Date: Tue, 13 Mar 2018 18:32:15 +0800 Subject: [PATCH 182/260] CA-285839: Fix return value if enabling SR-IOV via modprobe successful after reboot After reboot, we have to confirm SR-IOV is enabled successfully. If the numvfs equals to our target maxvfs, then modprobe successfully. Signed-off-by: Wei Xie --- networkd/network_server.ml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 3f8ef2bb8..6088d99b8 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -148,8 +148,11 @@ let get_capabilities dev = | Some vf_param -> debug "enable SR-IOV on a device: %s via modprobe" dev; (if enable then Modprobe.get_maxvfs driver config else Ok 0) >>= fun numvfs -> - Modprobe.config_sriov driver vf_param numvfs >>= fun _ -> - Ok Modprobe_successful_requires_reboot + if numvfs = Sysfs.get_sriov_numvfs dev then Ok Modprobe_successful + else begin + Modprobe.config_sriov driver vf_param numvfs >>= fun _ -> + Ok Modprobe_successful_requires_reboot + end | None -> debug "enable SR-IOV on a device: %s via sysfs" dev; (if enable then Sysfs.get_sriov_maxvfs dev else Ok 0) >>= fun numvfs -> From 4630eb77a366177e40f5668fd77eb74e48035013 Mon Sep 17 00:00:00 2001 From: Wei Xie Date: Thu, 15 Mar 2018 11:01:37 +0800 Subject: [PATCH 183/260] CA-286029: Disabling SR-IOV is failed on sysfs NIC Before using sysfs interface to disable SR-IOV, the function should ensure all VFs are unbound from pciback driver. Signed-off-by: Wei Xie --- lib/network_utils.ml | 1 - networkd/network_server.ml | 5 ++++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 1350ee97c..c055b2774 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -328,7 +328,6 @@ module Sysfs = struct let set_sriov_numvfs dev num_vfs = let interface = getpath dev "device/sriov_numvfs" in - let oc = open_out interface in try write_one_line interface (string_of_int num_vfs); if get_sriov_numvfs dev = num_vfs then Result.Ok () diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 6088d99b8..f6515b5ae 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -155,7 +155,10 @@ let get_capabilities dev = end | None -> debug "enable SR-IOV on a device: %s via sysfs" dev; - (if enable then Sysfs.get_sriov_maxvfs dev else Ok 0) >>= fun numvfs -> + begin + if enable then Sysfs.get_sriov_maxvfs dev + else Sysfs.unbind_child_vfs dev >>= fun () -> Ok 0 + end >>= fun numvfs -> Sysfs.set_sriov_numvfs dev numvfs >>= fun _ -> Ok Sysfs_successful From bc702daf296836e2f4c4a7576af04be55e278848 Mon Sep 17 00:00:00 2001 From: Wei Xie Date: Tue, 20 Mar 2018 16:08:04 +0800 Subject: [PATCH 184/260] CA-286290: Refine Configuring VF. - Fix the error to config rate - Add logs for VF configuration Signed-off-by: Wei Xie --- lib/network_utils.ml | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index c055b2774..fbb908fd8 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -531,19 +531,22 @@ info "Found at [ %s ]" (String.concat ", " (List.map string_of_int indices)); let set_vf_mac dev index mac = try + debug "Setting VF MAC address for dev: %s, index: %d, MAC: %s" dev index mac; Result.Ok (link_set dev ["vf"; string_of_int index; "mac"; mac]) - with _ -> Result.Error (Fail_to_set_vf_mac, "Failed to set vf mac for: " ^ dev) + with _ -> Result.Error (Fail_to_set_vf_mac, "Failed to set VF MAC for: " ^ dev) let set_vf_vlan dev index vlan = try + debug "Setting VF VLAN for dev: %s, index: %d, VLAN: %d" dev index vlan; Result.Ok (link_set dev ["vf"; string_of_int index; "vlan"; string_of_int vlan]) - with _ -> Result.Error (Fail_to_set_vf_vlan, "Failed to set vf vlan for: " ^ dev) + with _ -> Result.Error (Fail_to_set_vf_vlan, "Failed to set VF VLAN for: " ^ dev) (* We know some NICs do not support config VF Rate, so will explicitly tell XAPI this error*) let set_vf_rate dev index rate = try - Result.Ok (link_set dev ["vf"; string_of_int index; "mac"; string_of_int rate]) - with _ -> Result.Error (Fail_to_set_vf_rate, "Failed to set vf rate for: " ^ dev) + debug "Setting VF rate for dev: %s, index: %d, rate: %d" dev index rate; + Result.Ok (link_set dev ["vf"; string_of_int index; "rate"; string_of_int rate]) + with _ -> Result.Error (Fail_to_set_vf_rate, "Failed to set VF rate for: " ^ dev) end module Linux_bonding = struct From d04940817c321156a8050da806844246238428ea Mon Sep 17 00:00:00 2001 From: Wei Xie Date: Tue, 20 Mar 2018 16:08:31 +0800 Subject: [PATCH 185/260] CA-286290: A no-vlan SRIOV VIF shouldn't have a VLAN tag In order to ensure the Networkd to be idempotent, configuring VF with no VLAN and rate have to reset vlan and rate, since the VF might have previous configuration. Refering to http://gittup.org/cgi-bin/man/man2html?ip-link+8, set VLAN and rate to 0 means to reset them. Signed-off-by: Wei Xie --- networkd/network_server.ml | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index f6515b5ae..6572dad49 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -179,16 +179,22 @@ let get_capabilities dev = ) () let make_vf_conf_internal pcibuspath mac vlan rate = - let exe_except_none f = function - | None -> Result.Ok () - | Some a -> f a + let config_or_otherwise_reset config_f reset_f = function + | None -> reset_f () + | Some a -> config_f a in let open Rresult.R.Infix in Sysfs.parent_device_of_vf pcibuspath >>= fun dev -> Sysfs.device_index_of_vf dev pcibuspath >>= fun index -> - exe_except_none (Ip.set_vf_mac dev index) mac >>= fun () -> - exe_except_none (Ip.set_vf_vlan dev index) vlan >>= fun () -> - exe_except_none (Ip.set_vf_rate dev index) rate + config_or_otherwise_reset (Ip.set_vf_mac dev index) + (fun () -> Result.Ok ()) mac >>= fun () -> + (* In order to ensure the Networkd to be idempotent, configuring VF with no VLAN and rate + have to reset vlan and rate, since the VF might have previous configuration. Refering to + http://gittup.org/cgi-bin/man/man2html?ip-link+8, set VLAN and rate to 0 means to reset them *) + config_or_otherwise_reset (Ip.set_vf_vlan dev index) + (fun () -> Ip.set_vf_vlan dev index 0) vlan >>= fun () -> + config_or_otherwise_reset (Ip.set_vf_rate dev index) + (fun () -> Ip.set_vf_rate dev index 0) rate let make_vf_config dbg pci_address (vf_info : sriov_pci_t) = Debug.with_thread_associated dbg (fun () -> From d576dbe54742b1363fa1ec0629868ca2dabe38b7 Mon Sep 17 00:00:00 2001 From: Wei Xie Date: Mon, 9 Apr 2018 15:16:44 +0800 Subject: [PATCH 186/260] CA-287340: Slave reboot with unexpect enabled SRIOV. Even if the current numvfs equals to the target numvfs, it is still needed to update SR-IOV modprobe config file, as the SR-IOV enabing takes effect after reboot. For example, a user enables SR-IOV and disables it immediately without a reboot. Signed-off-by: Wei Xie --- networkd/network_server.ml | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 6572dad49..104d2ffdf 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -148,11 +148,15 @@ let get_capabilities dev = | Some vf_param -> debug "enable SR-IOV on a device: %s via modprobe" dev; (if enable then Modprobe.get_maxvfs driver config else Ok 0) >>= fun numvfs -> - if numvfs = Sysfs.get_sriov_numvfs dev then Ok Modprobe_successful - else begin - Modprobe.config_sriov driver vf_param numvfs >>= fun _ -> + (* CA-287340: Even if the current numvfs equals to the target numvfs, + it is still needed to update SR-IOV modprobe config file, as the + SR-IOV enabing takes effect after reboot. For example, a user + enables SR-IOV and disables it immediately without a reboot.*) + Modprobe.config_sriov driver vf_param numvfs >>= fun _ -> + if numvfs = Sysfs.get_sriov_numvfs dev then + Ok Modprobe_successful + else Ok Modprobe_successful_requires_reboot - end | None -> debug "enable SR-IOV on a device: %s via sysfs" dev; begin From ccfb632bf899a4e5412964c5681720b8cab755bb Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Thu, 10 May 2018 17:07:21 +0100 Subject: [PATCH 187/260] network_utils: reduce warnings Signed-off-by: Marcello Seri --- lib/network_utils.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index fbb908fd8..395cf09a7 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -246,7 +246,7 @@ module Sysfs = struct try Sys.readdir ("/sys/bus/pci/drivers/" ^ driver) |> Array.to_list - |> List.filter (Re.execp (Re_perl.compile_pat "\d+:\d+:\d+\.\d+")) + |> List.filter (Re.execp (Re.Perl.compile_pat "\\d+:\\d+:\\d+\\.\\d+")) |> List.length with _ -> 0 @@ -263,7 +263,7 @@ module Sysfs = struct Result. Ok ( Sys.readdir device_path |> Array.to_list - |> List.filter (Re.execp (Re_perl.compile_pat "virtfn(\d+)")) (* List elements are like "virtfn1" *) + |> List.filter (Re.execp (Re.Perl.compile_pat "virtfn(\\d+)")) (* List elements are like "virtfn1" *) |> List.map (Filename.concat device_path) ) with _ -> Result.Error (Vf_sysfs_path_not_found, "Can not get child vfs sysfs paths for " ^ dev) @@ -274,7 +274,7 @@ module Sysfs = struct get_child_vfs_sysfs_paths parent_dev >>= fun paths -> let group = List.find (fun x -> Astring.String.is_infix ~affix:pcibuspath (Unix.readlink x)) paths - |> Re.exec_opt (Re_perl.compile_pat "virtfn(\d+)") + |> Re.exec_opt (Re.Perl.compile_pat "virtfn(\\d+)") in match group with | None -> Result.Error (Vf_index_not_found, "Can not get device index for " ^ pcibuspath) @@ -1323,7 +1323,7 @@ module Dracut = struct try info "Building initrd..."; let img_name = call_script !uname ["-r"] |> String.trim in - call ["-f"; Printf.sprintf "/boot/initrd-%s.img" img_name; img_name]; + call ["-f"; Printf.sprintf "/boot/initrd-%s.img" img_name; img_name] |> ignore; Result.Ok () with _ -> Result.Error (Fail_to_rebuild_initrd, "Error occurs in building initrd") end @@ -1337,7 +1337,7 @@ module Modinfo = struct let out = call ["--parameter"; driver] |> String.trim |> String.split_on_char '\n' in - let re = Re_perl.compile_pat "\((.*)\)$" in + let re = Re.Perl.compile_pat "\\((.*)\\)$" in let has_array_of str = match Re.exec_opt re str with | None -> false @@ -1451,8 +1451,8 @@ module Modprobe = struct | _ -> s in let trimed_s = String.trim s in - if Re.execp (Re_perl.compile_pat ("options[ \t]+" ^ driver)) trimed_s then - let driver_options = Re.split (Re_perl.compile_pat "[ \t]+") trimed_s in + if Re.execp (Re.Perl.compile_pat ("options[ \\t]+" ^ driver)) trimed_s then + let driver_options = Re.split (Re.Perl.compile_pat "[ \\t]+") trimed_s in List.map parse_driver_options driver_options |> String.concat " " else From 83d8d03d19b26b033ff05d34ab19e601352a7126 Mon Sep 17 00:00:00 2001 From: YarsinCitrix Date: Wed, 30 May 2018 17:20:04 +0800 Subject: [PATCH 188/260] CA-236855: VM.clean_shutdown task not completing on slave Use the newly created read_timeout and write_timeout to process input and output from outside. This avoids requests getting stuck if the pvsproxy daemon does not respond. Modified test case to remove the cases that is not applied. Signed-off-by: YarsinCitrix --- lib/jbuild | 4 +- lib/jsonrpc_client.ml | 133 +++++++++++++++++++++++++----------- lib/jsonrpc_client.mli | 10 ++- networkd/networkd.ml | 3 + test/test_jsonrpc_client.ml | 7 +- xapi-networkd.opam | 3 +- 6 files changed, 111 insertions(+), 49 deletions(-) diff --git a/lib/jbuild b/lib/jbuild index 372840d24..0a93d5a32 100644 --- a/lib/jbuild +++ b/lib/jbuild @@ -5,6 +5,8 @@ (flags (:standard :standard -bin-annot -safe-string)) (libraries (astring forkexec + mtime + mtime.clock.os rpclib systemd threads @@ -14,4 +16,4 @@ xcp.network)) (wrapped false) ) -) \ No newline at end of file +) diff --git a/lib/jsonrpc_client.ml b/lib/jsonrpc_client.ml index e6c228e3f..49ea621bd 100644 --- a/lib/jsonrpc_client.ml +++ b/lib/jsonrpc_client.ml @@ -17,49 +17,102 @@ module D = Debug.Make(struct let name = "jsonrpc_client" end) open D -let input_json_object fin = - let buf = Buffer.create 1024 in - let brace_cnt = ref 0 in - let in_string = ref false in - let last_char () = Buffer.nth buf (Buffer.length buf - 1) in - let rec get () = - let c = input_char fin in +exception Timeout +exception Read_error + +let json_rpc_max_len = ref 65536 (* Arbitrary maximum length of RPC response *) +let json_rpc_read_timeout = ref 60000000000L (* timeout value in ns when reading RPC response *) +let json_rpc_write_timeout = ref 60000000000L (* timeout value in ns when writing RPC request *) + +let to_s s = (Int64.to_float s) *. 1e-9 + +(* Read the entire contents of the fd, of unknown length *) +let timeout_read fd timeout = + let buf = Buffer.create !json_rpc_max_len in + let read_start = Mtime_clock.counter () in + let get_total_used_time () = Mtime.Span.to_uint64_ns (Mtime_clock.count read_start) in + let rec inner max_time max_bytes = + let (ready_to_read, _, _) = try Unix.select [fd] [] [] (to_s max_time) with + (* in case the unix.select call fails in situation like interrupt *) + | Unix.Unix_error(Unix.EINTR,_,_) -> [], [], [] + in + (* This is not accurate the calculate time just for the select part. However, we + * think the read time will be minor comparing to the scale of tens of seconds. + * the current style will be much concise in code. *) + let remain_time = + let used_time = get_total_used_time () in + Int64.sub timeout used_time + in + if remain_time < 0L then begin - match c with - | '{' when not !in_string -> brace_cnt := !brace_cnt + 1 - | '}' when not !in_string -> brace_cnt := !brace_cnt - 1 - | '"' when !in_string && (last_char () <> '\\') -> in_string := false - | '"' when not !in_string -> in_string := true - | _ -> () + debug "Timeout after read %d" (Buffer.length buf); + raise Timeout end; - Buffer.add_char buf c; - if !brace_cnt > 0 then - get () + if List.mem fd ready_to_read then + begin + let bytes = Bytes.make 4096 '\000' in + match Unix.read fd bytes 0 4096 with + | 0 -> Buffer.contents buf (* EOF *) + | n -> + if n > max_bytes then + begin + debug "exceeding maximum read limit %d, clear buffer" !json_rpc_max_len; + Buffer.clear buf; + raise Read_error + end + else + begin + Buffer.add_subbytes buf bytes 0 n; + inner remain_time (max_bytes - n) + end + | exception Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR),_,_) -> + inner remain_time max_bytes + end + else inner remain_time max_bytes in - get (); - Buffer.contents buf - -let receive fin = - let obj = input_json_object fin in - debug "Response: %s" obj; - Jsonrpc.response_of_string obj + inner timeout !json_rpc_max_len -let with_connection sockaddr f = - let fin, fout = Unix.open_connection sockaddr in - debug "Connected."; - let result = f fin fout in - Unix.shutdown_connection fin; - close_in fin; - debug "Shut down."; - result +(* Write as many bytes to a file descriptor as possible from data before a given clock time. *) +(* Raises Timeout exception if the number of bytes written is less than the specified length. *) +(* Writes into the file descriptor at the current cursor position. *) +let timeout_write filedesc total_length data response_time = + let write_start = Mtime_clock.counter () in + let get_total_used_time () = Mtime.Span.to_uint64_ns (Mtime_clock.count write_start) in + let rec inner_write offset max_time = + let (_, ready_to_write, _) = try Unix.select [] [filedesc] [] (to_s max_time) with + (* in case the unix.select call fails in situation like interrupt *) + | Unix.Unix_error(Unix.EINTR,_,_) -> [], [], [] + in + let remain_time = + let used_time = get_total_used_time () in + Int64.sub response_time used_time + in + if remain_time < 0L then + begin + debug "Timeout to write %d at offset %d" total_length offset; + raise Timeout + end; + if List.mem filedesc ready_to_write then + begin + let length = total_length - offset in + let bytes_written = + (try Unix.single_write filedesc data offset length with + | Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR),_,_) -> 0) + in + let new_offset = offset + bytes_written in + if length = bytes_written then () + else inner_write new_offset remain_time + end + else inner_write offset remain_time + in + inner_write 0 response_time let with_rpc ?(version=Jsonrpc.V2) ~path ~call () = - let sockaddr = Unix.ADDR_UNIX path in - with_connection sockaddr (fun fin fout -> - let req = Jsonrpc.string_of_call ~version call in - debug "Request: %s" req; - output_string fout req; - flush fout; - receive fin - ) - + let uri = Uri.of_string (Printf.sprintf "file://%s" path) in + Open_uri.with_open_uri uri (fun s -> + Unix.set_nonblock s; + let req = Bytes.of_string (Jsonrpc.string_of_call ~version call) in + timeout_write s (Bytes.length req) req !json_rpc_write_timeout; + let res = timeout_read s !json_rpc_read_timeout in + debug "Response: %s" res; + Jsonrpc.response_of_string res) diff --git a/lib/jsonrpc_client.mli b/lib/jsonrpc_client.mli index c7dd21ee6..c0e40ca06 100644 --- a/lib/jsonrpc_client.mli +++ b/lib/jsonrpc_client.mli @@ -12,9 +12,15 @@ * GNU Lesser General Public License for more details. *) +exception Timeout +exception Read_error + +val json_rpc_max_len : int ref +val json_rpc_read_timeout : int64 ref +val json_rpc_write_timeout : int64 ref + +val timeout_read : Unix.file_descr -> int64 -> string (** Do an JSON-RPC call to a server that is listening on a Unix domain * socket at the given path. *) val with_rpc : ?version:Jsonrpc.version -> path:string -> call:Rpc.call -> unit -> Rpc.response -(** Read an entire JSON object from an input channel. *) -val input_json_object : in_channel -> string diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 015b55529..4b2f90068 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -64,6 +64,9 @@ let options = [ "dracut-cmd-path", Arg.Set_string Network_utils.dracut, (fun () -> !Network_utils.dracut), "Path to the Unix command dracut"; "dracut-timeout", Arg.Set_float Network_utils.dracut_timeout, (fun () -> string_of_float !Network_utils.dracut_timeout), "Default value for the dracut command timeout"; "modinfo-cmd-path", Arg.Set_string Network_utils.modinfo, (fun () -> !Network_utils.modinfo), "Path to the Unix command modinfo"; + "json-rpc-max-len", Arg.Set_int Jsonrpc_client.json_rpc_max_len, (fun () -> string_of_int !Jsonrpc_client.json_rpc_max_len), "Maximum buffer size for Json RPC response"; + "json-rpc-read-timeout", Arg.Int (fun x -> Jsonrpc_client.json_rpc_read_timeout := Int64.(mul 1000000L (of_int x))), (fun () -> Int64.(to_string (div !Jsonrpc_client.json_rpc_read_timeout 1000000L))), "JSON RPC response read timeout value in ms"; + "json-rpc-write-timeout", Arg.Int (fun x -> Jsonrpc_client.json_rpc_write_timeout := Int64.(mul 1000000L (of_int x))), (fun () -> Int64.(to_string (div !Jsonrpc_client.json_rpc_write_timeout 1000000L))), "JSON RPC write timeout value in ms"; ] let start server = diff --git a/test/test_jsonrpc_client.ml b/test/test_jsonrpc_client.ml index fa7452ccc..c1811757a 100644 --- a/test/test_jsonrpc_client.ml +++ b/test/test_jsonrpc_client.ml @@ -41,7 +41,7 @@ module Input_json_object = Generic.Make (struct let fin = open_in (Filename.concat dir filename) in let response = try - let json = Jsonrpc_client.input_json_object fin in + let json = Jsonrpc_client.timeout_read (Unix.descr_of_in_channel fin) 5_000_000_000L in let rpc = Jsonrpc.of_string json in Right rpc with @@ -57,11 +57,8 @@ module Input_json_object = Generic.Make (struct "good_call.json", Right good_call; (* A file containing a partial JSON object. *) - "short_call.json", Left End_of_file; + "short_call.json", Left Parse_error; - (* A file containing a JSON object, plus some more characters at the end. *) - "good_call_plus.json", Right good_call; - (* A file containing some invalid JSON object. *) "bad_call.json", (Left Parse_error); ] diff --git a/xapi-networkd.opam b/xapi-networkd.opam index 33b3114f7..2fce2fc60 100644 --- a/xapi-networkd.opam +++ b/xapi-networkd.opam @@ -10,6 +10,7 @@ build-test: ["jbuilder" "runtest" "-p" name] depends: [ "jbuilder" {build} "astring" + "mtime" "netlink" "rpc" "systemd" @@ -23,4 +24,4 @@ depends: [ "xapi-stdext-threads" "xapi-stdext-unix" "xen-api-client" -] \ No newline at end of file +] From a4f05fa62f05af15fd5a52b3e40b92e3ba5e2429 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 12 Jun 2018 15:13:08 +0100 Subject: [PATCH 189/260] CA-291495: Fall back to Ip.link_set_mtu if OVS.set_mtu fails OVS.set_mtu is a new function (since ed2151f8), which requires a newer version of the OVS that supports the mtu_request feature. If the installed OVS does not have this feature, then the function will raise an exception. For compatibility reasons, we now catch this exception and fall back to Ip.link_set_mtu. Signed-off-by: Rob Hoes --- networkd/network_server.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 104d2ffdf..7f34f8e18 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -443,7 +443,11 @@ module Interface = struct debug "Configuring MTU for %s: %d" name mtu; update_config name {(get_config name) with mtu}; match !backend_kind with - | Openvswitch -> ignore (Ovs.set_mtu name mtu) + | Openvswitch -> + (try + ignore (Ovs.set_mtu name mtu) + with _ -> + Ip.link_set_mtu name mtu) | Bridge -> Ip.link_set_mtu name mtu ) () From fb73f330d0014999f60b956e49c120ad8bee4490 Mon Sep 17 00:00:00 2001 From: YarsinCitrix Date: Thu, 21 Jun 2018 04:01:59 +0100 Subject: [PATCH 190/260] CA-291197: Toolstack no longer ignores junk at the end of JSON-RPC response The previous changes for CA-236855 no longer tolerant junk at the end of input from the pvsproxy, which makes the interface more fragile. To build a more robust interface in case of issue on the pvsproxy side, new option strict from jsonrpc is used to interpret the response, so tailing junk is ignored. Signed-off-by: YarsinCitrix --- lib/jsonrpc_client.ml | 2 +- test/test_jsonrpc_client.ml | 5 ++++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/lib/jsonrpc_client.ml b/lib/jsonrpc_client.ml index 49ea621bd..3525ca1fb 100644 --- a/lib/jsonrpc_client.ml +++ b/lib/jsonrpc_client.ml @@ -115,4 +115,4 @@ let with_rpc ?(version=Jsonrpc.V2) ~path ~call () = timeout_write s (Bytes.length req) req !json_rpc_write_timeout; let res = timeout_read s !json_rpc_read_timeout in debug "Response: %s" res; - Jsonrpc.response_of_string res) + Jsonrpc.response_of_string ~strict:false res) diff --git a/test/test_jsonrpc_client.ml b/test/test_jsonrpc_client.ml index c1811757a..a3a7f31aa 100644 --- a/test/test_jsonrpc_client.ml +++ b/test/test_jsonrpc_client.ml @@ -42,7 +42,7 @@ module Input_json_object = Generic.Make (struct let response = try let json = Jsonrpc_client.timeout_read (Unix.descr_of_in_channel fin) 5_000_000_000L in - let rpc = Jsonrpc.of_string json in + let rpc = Jsonrpc.of_string ~strict:false json in Right rpc with | End_of_file -> Left End_of_file @@ -59,6 +59,9 @@ module Input_json_object = Generic.Make (struct (* A file containing a partial JSON object. *) "short_call.json", Left Parse_error; + (* A file containing a JSON object, plus some more characters at the end. *) + "good_call_plus.json", Right good_call; + (* A file containing some invalid JSON object. *) "bad_call.json", (Left Parse_error); ] From 4ac4a87c842977bfbd01f52245cbcfcac4cac098 Mon Sep 17 00:00:00 2001 From: Gabor Igloi Date: Mon, 25 Jun 2018 23:02:28 +0100 Subject: [PATCH 191/260] network_monitor_thread: use Xmlrpc_client instead of Rpc_client The Rpc_client module has been removed from ocaml-rpc Signed-off-by: Gabor Igloi --- networkd/jbuild | 1 - networkd/network_monitor_thread.ml | 8 +++----- 2 files changed, 3 insertions(+), 6 deletions(-) diff --git a/networkd/jbuild b/networkd/jbuild index a757b7b01..427f78d96 100644 --- a/networkd/jbuild +++ b/networkd/jbuild @@ -22,7 +22,6 @@ networklibs profiling rpclib - rpclib.unix systemd threads xapi-stdext-monadic diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index 7afad2dd7..c91453583 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -28,11 +28,9 @@ let monitor_whitelist = ref [ "vif"; (* This includes "tap" owing to the use of standardise_name below *) ] -let xapi_rpc request = - Rpc_client.do_rpc_unix - ~content_type:(Rpc_client.content_type_of_string "text/xml") - ~filename:(Filename.concat "/var/lib/xcp" "xapi") - ~path:"/" request +let xapi_rpc xml = + let open Xmlrpc_client in + XMLRPC_protocol.rpc ~srcstr:"xcp-networkd" ~dststr:"xapi" ~transport:(Unix "/var/xapi/xapi") ~http:(xmlrpc ~version:"1.0" "/") xml let send_bond_change_alert dev interfaces message = let ifaces = String.concat "+" (List.sort String.compare interfaces) in From 1e240d3e5ed3c0979a15797bb42c98d680b0da52 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 28 Sep 2018 15:17:55 +0100 Subject: [PATCH 192/260] Reindent with spaces It's got to be done. Signed-off-by: Rob Hoes --- lib/jsonrpc_client.ml | 162 +- lib/network_config.ml | 272 +-- lib/network_utils.ml | 2704 +++++++++++++------------- networkd/network_monitor.ml | 10 +- networkd/network_monitor_thread.ml | 522 ++--- networkd/network_server.ml | 2184 ++++++++++----------- networkd/networkd.ml | 128 +- networkd_db/networkd_db.ml | 182 +- profiling/coverage.ml | 12 +- profiling/coverage.mli | 2 +- test/jsonrpc_dummy.ml | 22 +- test/network_test.ml | 10 +- test/network_test_lacp_properties.ml | 164 +- test/test_jsonrpc_client.ml | 84 +- 14 files changed, 3229 insertions(+), 3229 deletions(-) diff --git a/lib/jsonrpc_client.ml b/lib/jsonrpc_client.ml index 3525ca1fb..133498ed5 100644 --- a/lib/jsonrpc_client.ml +++ b/lib/jsonrpc_client.ml @@ -28,91 +28,91 @@ let to_s s = (Int64.to_float s) *. 1e-9 (* Read the entire contents of the fd, of unknown length *) let timeout_read fd timeout = - let buf = Buffer.create !json_rpc_max_len in - let read_start = Mtime_clock.counter () in - let get_total_used_time () = Mtime.Span.to_uint64_ns (Mtime_clock.count read_start) in - let rec inner max_time max_bytes = - let (ready_to_read, _, _) = try Unix.select [fd] [] [] (to_s max_time) with - (* in case the unix.select call fails in situation like interrupt *) - | Unix.Unix_error(Unix.EINTR,_,_) -> [], [], [] - in - (* This is not accurate the calculate time just for the select part. However, we - * think the read time will be minor comparing to the scale of tens of seconds. - * the current style will be much concise in code. *) - let remain_time = - let used_time = get_total_used_time () in - Int64.sub timeout used_time - in - if remain_time < 0L then - begin - debug "Timeout after read %d" (Buffer.length buf); - raise Timeout - end; - if List.mem fd ready_to_read then - begin - let bytes = Bytes.make 4096 '\000' in - match Unix.read fd bytes 0 4096 with - | 0 -> Buffer.contents buf (* EOF *) - | n -> - if n > max_bytes then - begin - debug "exceeding maximum read limit %d, clear buffer" !json_rpc_max_len; - Buffer.clear buf; - raise Read_error - end - else - begin - Buffer.add_subbytes buf bytes 0 n; - inner remain_time (max_bytes - n) - end - | exception Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR),_,_) -> - inner remain_time max_bytes - end - else inner remain_time max_bytes - in - inner timeout !json_rpc_max_len + let buf = Buffer.create !json_rpc_max_len in + let read_start = Mtime_clock.counter () in + let get_total_used_time () = Mtime.Span.to_uint64_ns (Mtime_clock.count read_start) in + let rec inner max_time max_bytes = + let (ready_to_read, _, _) = try Unix.select [fd] [] [] (to_s max_time) with + (* in case the unix.select call fails in situation like interrupt *) + | Unix.Unix_error(Unix.EINTR,_,_) -> [], [], [] + in + (* This is not accurate the calculate time just for the select part. However, we + * think the read time will be minor comparing to the scale of tens of seconds. + * the current style will be much concise in code. *) + let remain_time = + let used_time = get_total_used_time () in + Int64.sub timeout used_time + in + if remain_time < 0L then + begin + debug "Timeout after read %d" (Buffer.length buf); + raise Timeout + end; + if List.mem fd ready_to_read then + begin + let bytes = Bytes.make 4096 '\000' in + match Unix.read fd bytes 0 4096 with + | 0 -> Buffer.contents buf (* EOF *) + | n -> + if n > max_bytes then + begin + debug "exceeding maximum read limit %d, clear buffer" !json_rpc_max_len; + Buffer.clear buf; + raise Read_error + end + else + begin + Buffer.add_subbytes buf bytes 0 n; + inner remain_time (max_bytes - n) + end + | exception Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR),_,_) -> + inner remain_time max_bytes + end + else inner remain_time max_bytes + in + inner timeout !json_rpc_max_len (* Write as many bytes to a file descriptor as possible from data before a given clock time. *) (* Raises Timeout exception if the number of bytes written is less than the specified length. *) (* Writes into the file descriptor at the current cursor position. *) let timeout_write filedesc total_length data response_time = - let write_start = Mtime_clock.counter () in - let get_total_used_time () = Mtime.Span.to_uint64_ns (Mtime_clock.count write_start) in - let rec inner_write offset max_time = - let (_, ready_to_write, _) = try Unix.select [] [filedesc] [] (to_s max_time) with - (* in case the unix.select call fails in situation like interrupt *) - | Unix.Unix_error(Unix.EINTR,_,_) -> [], [], [] - in - let remain_time = - let used_time = get_total_used_time () in - Int64.sub response_time used_time - in - if remain_time < 0L then - begin - debug "Timeout to write %d at offset %d" total_length offset; - raise Timeout - end; - if List.mem filedesc ready_to_write then - begin - let length = total_length - offset in - let bytes_written = - (try Unix.single_write filedesc data offset length with - | Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR),_,_) -> 0) - in - let new_offset = offset + bytes_written in - if length = bytes_written then () - else inner_write new_offset remain_time - end - else inner_write offset remain_time - in - inner_write 0 response_time + let write_start = Mtime_clock.counter () in + let get_total_used_time () = Mtime.Span.to_uint64_ns (Mtime_clock.count write_start) in + let rec inner_write offset max_time = + let (_, ready_to_write, _) = try Unix.select [] [filedesc] [] (to_s max_time) with + (* in case the unix.select call fails in situation like interrupt *) + | Unix.Unix_error(Unix.EINTR,_,_) -> [], [], [] + in + let remain_time = + let used_time = get_total_used_time () in + Int64.sub response_time used_time + in + if remain_time < 0L then + begin + debug "Timeout to write %d at offset %d" total_length offset; + raise Timeout + end; + if List.mem filedesc ready_to_write then + begin + let length = total_length - offset in + let bytes_written = + (try Unix.single_write filedesc data offset length with + | Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR),_,_) -> 0) + in + let new_offset = offset + bytes_written in + if length = bytes_written then () + else inner_write new_offset remain_time + end + else inner_write offset remain_time + in + inner_write 0 response_time let with_rpc ?(version=Jsonrpc.V2) ~path ~call () = - let uri = Uri.of_string (Printf.sprintf "file://%s" path) in - Open_uri.with_open_uri uri (fun s -> - Unix.set_nonblock s; - let req = Bytes.of_string (Jsonrpc.string_of_call ~version call) in - timeout_write s (Bytes.length req) req !json_rpc_write_timeout; - let res = timeout_read s !json_rpc_read_timeout in - debug "Response: %s" res; - Jsonrpc.response_of_string ~strict:false res) + let uri = Uri.of_string (Printf.sprintf "file://%s" path) in + Open_uri.with_open_uri uri (fun s -> + Unix.set_nonblock s; + let req = Bytes.of_string (Jsonrpc.string_of_call ~version call) in + timeout_write s (Bytes.length req) req !json_rpc_write_timeout; + let res = timeout_read s !json_rpc_read_timeout in + debug "Response: %s" res; + Jsonrpc.response_of_string ~strict:false res) diff --git a/lib/network_config.ml b/lib/network_config.ml index d7318d896..0b4f35669 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -25,148 +25,148 @@ let empty_config = default_config let config_file_path = "/var/lib/xcp/networkd.db" let bridge_naming_convention (device: string) = - if Astring.String.is_prefix ~affix:"eth" device - then ("xenbr" ^ (String.sub device 3 (String.length device - 3))) - else ("br" ^ device) + if Astring.String.is_prefix ~affix:"eth" device + then ("xenbr" ^ (String.sub device 3 (String.length device - 3))) + else ("br" ^ device) let read_management_conf () = - try - let management_conf = Xapi_stdext_unix.Unixext.string_of_file ("/etc/firstboot.d/data/management.conf") in - let args = Astring.String.cuts ~empty:false ~sep:"\n" (String.trim management_conf) in - let args = List.map (fun s -> - match (Astring.String.cuts ~sep:"=" s) with - | k :: [v] -> k, Astring.String.trim ~drop:((=) '\'') v - | _ -> "", "" - ) args in - debug "Firstboot file management.conf has: %s" (String.concat "; " (List.map (fun (k, v) -> k ^ "=" ^ v) args)); - let device = List.assoc "LABEL" args in - let vlan = if List.mem_assoc "VLAN" args then Some (List.assoc "VLAN" args) else None in - Inventory.reread_inventory (); - let bridge_name = Inventory.lookup Inventory._management_interface in - debug "Management bridge in inventory file: %s" bridge_name; - let mac = Network_utils.Ip.get_mac device in - let ipv4_conf, ipv4_gateway, dns = - match List.assoc "MODE" args with - | "static" -> - let ip = List.assoc "IP" args |> Unix.inet_addr_of_string in - let prefixlen = List.assoc "NETMASK" args |> netmask_to_prefixlen in - let gateway = - if List.mem_assoc "GATEWAY" args then - Some (List.assoc "GATEWAY" args |> Unix.inet_addr_of_string) - else None - in - let nameservers = - if List.mem_assoc "DNS" args && List.assoc "DNS" args <> "" then - List.map Unix.inet_addr_of_string (Astring.String.cuts ~empty:false ~sep:"," (List.assoc "DNS" args)) - else [] - in - let domains = - if List.mem_assoc "DOMAIN" args && List.assoc "DOMAIN" args <> "" then - Astring.String.cuts ~empty:false ~sep:" " (List.assoc "DOMAIN" args) - else [] - in - let dns = nameservers, domains in - Static4 [ip, prefixlen], gateway, dns - | "dhcp" | _ -> - DHCP4, None, ([], []) - in - let phy_interface = {default_interface with persistent_i = true} in - let bridge_interface = {default_interface with ipv4_conf; ipv4_gateway; persistent_i = true} in - let interface_config, bridge_config = - let primary_bridge_conf = {default_bridge with - bridge_mac = Some mac; - ports = [device, {default_port with interfaces = [device]}]; - persistent_b = true - } in - if bridge_name = "" then - [], [] - else begin - match vlan with - | None -> - [device, phy_interface; bridge_name, bridge_interface], - [bridge_name, primary_bridge_conf] - | Some vlan -> - let parent = bridge_naming_convention device in - let secondary_bridge_conf = {default_bridge with - vlan = Some (parent, int_of_string vlan); - bridge_mac = (Some mac); - persistent_b = true - } in - let parent_bridge_interface = {default_interface with persistent_i = true} in - [device, phy_interface; parent, parent_bridge_interface; bridge_name, bridge_interface], - [parent, primary_bridge_conf; bridge_name, secondary_bridge_conf] - end - in - {interface_config = interface_config; bridge_config = bridge_config; - gateway_interface = Some bridge_name; dns_interface = Some bridge_name} - with e -> - error "Error while trying to read firstboot data: %s\n%s" - (Printexc.to_string e) (Printexc.get_backtrace ()); - raise Read_error + try + let management_conf = Xapi_stdext_unix.Unixext.string_of_file ("/etc/firstboot.d/data/management.conf") in + let args = Astring.String.cuts ~empty:false ~sep:"\n" (String.trim management_conf) in + let args = List.map (fun s -> + match (Astring.String.cuts ~sep:"=" s) with + | k :: [v] -> k, Astring.String.trim ~drop:((=) '\'') v + | _ -> "", "" + ) args in + debug "Firstboot file management.conf has: %s" (String.concat "; " (List.map (fun (k, v) -> k ^ "=" ^ v) args)); + let device = List.assoc "LABEL" args in + let vlan = if List.mem_assoc "VLAN" args then Some (List.assoc "VLAN" args) else None in + Inventory.reread_inventory (); + let bridge_name = Inventory.lookup Inventory._management_interface in + debug "Management bridge in inventory file: %s" bridge_name; + let mac = Network_utils.Ip.get_mac device in + let ipv4_conf, ipv4_gateway, dns = + match List.assoc "MODE" args with + | "static" -> + let ip = List.assoc "IP" args |> Unix.inet_addr_of_string in + let prefixlen = List.assoc "NETMASK" args |> netmask_to_prefixlen in + let gateway = + if List.mem_assoc "GATEWAY" args then + Some (List.assoc "GATEWAY" args |> Unix.inet_addr_of_string) + else None + in + let nameservers = + if List.mem_assoc "DNS" args && List.assoc "DNS" args <> "" then + List.map Unix.inet_addr_of_string (Astring.String.cuts ~empty:false ~sep:"," (List.assoc "DNS" args)) + else [] + in + let domains = + if List.mem_assoc "DOMAIN" args && List.assoc "DOMAIN" args <> "" then + Astring.String.cuts ~empty:false ~sep:" " (List.assoc "DOMAIN" args) + else [] + in + let dns = nameservers, domains in + Static4 [ip, prefixlen], gateway, dns + | "dhcp" | _ -> + DHCP4, None, ([], []) + in + let phy_interface = {default_interface with persistent_i = true} in + let bridge_interface = {default_interface with ipv4_conf; ipv4_gateway; persistent_i = true} in + let interface_config, bridge_config = + let primary_bridge_conf = {default_bridge with + bridge_mac = Some mac; + ports = [device, {default_port with interfaces = [device]}]; + persistent_b = true + } in + if bridge_name = "" then + [], [] + else begin + match vlan with + | None -> + [device, phy_interface; bridge_name, bridge_interface], + [bridge_name, primary_bridge_conf] + | Some vlan -> + let parent = bridge_naming_convention device in + let secondary_bridge_conf = {default_bridge with + vlan = Some (parent, int_of_string vlan); + bridge_mac = (Some mac); + persistent_b = true + } in + let parent_bridge_interface = {default_interface with persistent_i = true} in + [device, phy_interface; parent, parent_bridge_interface; bridge_name, bridge_interface], + [parent, primary_bridge_conf; bridge_name, secondary_bridge_conf] + end + in + {interface_config = interface_config; bridge_config = bridge_config; + gateway_interface = Some bridge_name; dns_interface = Some bridge_name} + with e -> + error "Error while trying to read firstboot data: %s\n%s" + (Printexc.to_string e) (Printexc.get_backtrace ()); + raise Read_error let write_config config = - try - let config_json = config |> Rpcmarshal.marshal typ_of_config_t |> Jsonrpc.to_string in - Xapi_stdext_unix.Unixext.write_string_to_file config_file_path config_json - with e -> - error "Error while trying to write networkd configuration: %s\n%s" - (Printexc.to_string e) (Printexc.get_backtrace ()); - raise Write_error + try + let config_json = config |> Rpcmarshal.marshal typ_of_config_t |> Jsonrpc.to_string in + Xapi_stdext_unix.Unixext.write_string_to_file config_file_path config_json + with e -> + error "Error while trying to write networkd configuration: %s\n%s" + (Printexc.to_string e) (Printexc.get_backtrace ()); + raise Write_error (* Porting network interaface to ppx: convert ipv4_routes from (string * int * string) list to {gateway:string; netmask:int; subnet:string} *) let convert_configuration cfg = - let open Yojson.Safe in - let convert_ipv4_routes cfg = - let convert_ipv4_route cfg = - match cfg with - | `List [`String gateway; `Int netmask; `String subnet] -> - debug "convert ipv4 route"; - `Assoc ["gateway", `String gateway; "netmask", `Int netmask; "subnet", `String subnet] - | other -> other - in - match cfg with - | `List l -> - `List (List.map convert_ipv4_route l) - | other -> other - in - let convert_interface_item cfg = - match cfg with - | `Assoc l -> - `Assoc (List.map (fun (k, v) -> - let v = if k = "ipv4_routes" then convert_ipv4_routes v else v in - k, v - ) l) - | other -> other - in - let convert_interface_config cfg = - match cfg with - | `Assoc l -> - `Assoc (List.map (fun (k, v) -> k, convert_interface_item v) l) - | other -> other - in - let json = match from_string cfg with - | `Assoc l -> - `Assoc (List.map (fun (k, v) -> - let v = if k = "interface_config" then convert_interface_config v else v in - k, v - ) l) - | other -> other - in - to_string json + let open Yojson.Safe in + let convert_ipv4_routes cfg = + let convert_ipv4_route cfg = + match cfg with + | `List [`String gateway; `Int netmask; `String subnet] -> + debug "convert ipv4 route"; + `Assoc ["gateway", `String gateway; "netmask", `Int netmask; "subnet", `String subnet] + | other -> other + in + match cfg with + | `List l -> + `List (List.map convert_ipv4_route l) + | other -> other + in + let convert_interface_item cfg = + match cfg with + | `Assoc l -> + `Assoc (List.map (fun (k, v) -> + let v = if k = "ipv4_routes" then convert_ipv4_routes v else v in + k, v + ) l) + | other -> other + in + let convert_interface_config cfg = + match cfg with + | `Assoc l -> + `Assoc (List.map (fun (k, v) -> k, convert_interface_item v) l) + | other -> other + in + let json = match from_string cfg with + | `Assoc l -> + `Assoc (List.map (fun (k, v) -> + let v = if k = "interface_config" then convert_interface_config v else v in + k, v + ) l) + | other -> other + in + to_string json let read_config () = - try - let config_json = Xapi_stdext_unix.Unixext.string_of_file config_file_path |> convert_configuration in - match config_json |> Jsonrpc.of_string |> Rpcmarshal.unmarshal typ_of_config_t with - | Result.Ok v -> v - | Result.Error (`Msg err_msg) -> - error "Read configuration error: %s" err_msg; - raise Read_error - with - | Unix.Unix_error (Unix.ENOENT, _, file) -> - info "Cannot read networkd configuration file %s because it does not exist." file; - raise Read_error - | e -> - info "Error while trying to read networkd configuration: %s\n%s" - (Printexc.to_string e) (Printexc.get_backtrace ()); - raise Read_error + try + let config_json = Xapi_stdext_unix.Unixext.string_of_file config_file_path |> convert_configuration in + match config_json |> Jsonrpc.of_string |> Rpcmarshal.unmarshal typ_of_config_t with + | Result.Ok v -> v + | Result.Error (`Msg err_msg) -> + error "Read configuration error: %s" err_msg; + raise Read_error + with + | Unix.Unix_error (Unix.ENOENT, _, file) -> + info "Cannot read networkd configuration file %s because it does not exist." file; + raise Read_error + | e -> + info "Error while trying to read networkd configuration: %s\n%s" + (Printexc.to_string e) (Printexc.get_backtrace ()); + raise Read_error diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 395cf09a7..0e8cecc95 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -28,21 +28,21 @@ exception Vlan_in_use of (string * int) exception PVS_proxy_connection_error type util_error = -| Bus_out_of_range -| Not_enough_mmio_resources -| Fail_to_set_vf_rate -| Fail_to_set_vf_vlan -| Fail_to_set_vf_mac -| Parent_device_of_vf_not_found -| Vf_index_not_found -| Fail_to_rebuild_initrd -| Fail_to_write_modprobe_cfg -| Fail_to_get_driver_name -| Fail_to_get_maxvfs -| No_sriov_capability -| Vf_sysfs_path_not_found -| Fail_to_unbind_from_driver -| Other + | Bus_out_of_range + | Not_enough_mmio_resources + | Fail_to_set_vf_rate + | Fail_to_set_vf_vlan + | Fail_to_set_vf_mac + | Parent_device_of_vf_not_found + | Vf_index_not_found + | Fail_to_rebuild_initrd + | Fail_to_write_modprobe_cfg + | Fail_to_get_driver_name + | Fail_to_get_maxvfs + | No_sriov_capability + | Vf_sysfs_path_not_found + | Fail_to_unbind_from_driver + | Other let iproute2 = "/sbin/ip" let resolv_conf = "/etc/resolv.conf" @@ -68,1301 +68,1301 @@ let enable_ipv6_mcast_snooping = ref false let mcast_snooping_disable_flood_unregistered = ref true let check_n_run run_func script args = - try - Unix.access script [ Unix.X_OK ]; - (* Use the same $PATH as xapi *) - let env = [| "PATH=" ^ (Sys.getenv "PATH") |] in - info "%s %s" script (String.concat " " args); - run_func env script args - with - | Unix.Unix_error (e, a, b) -> - error "Caught unix error: %s [%s, %s]" (Unix.error_message e) a b; - error "Assuming script %s doesn't exist" script; - raise (Script_missing script) - | Forkhelpers.Spawn_internal_error(stderr, stdout, e)-> - let message = - match e with - | Unix.WEXITED n -> Printf.sprintf "Exit code %d" n - | Unix.WSIGNALED s -> Printf.sprintf "Signaled %d" s (* Note that this is the internal ocaml signal number, see Sys module *) - | Unix.WSTOPPED s -> Printf.sprintf "Stopped %d" s - in - error "Call '%s %s' exited badly: %s [stdout = '%s'; stderr = '%s']" script - (String.concat " " args) message stdout stderr; - raise (Script_error ["script", script; "args", String.concat " " args; "code", - message; "stdout", stdout; "stderr", stderr]) + try + Unix.access script [ Unix.X_OK ]; + (* Use the same $PATH as xapi *) + let env = [| "PATH=" ^ (Sys.getenv "PATH") |] in + info "%s %s" script (String.concat " " args); + run_func env script args + with + | Unix.Unix_error (e, a, b) -> + error "Caught unix error: %s [%s, %s]" (Unix.error_message e) a b; + error "Assuming script %s doesn't exist" script; + raise (Script_missing script) + | Forkhelpers.Spawn_internal_error(stderr, stdout, e)-> + let message = + match e with + | Unix.WEXITED n -> Printf.sprintf "Exit code %d" n + | Unix.WSIGNALED s -> Printf.sprintf "Signaled %d" s (* Note that this is the internal ocaml signal number, see Sys module *) + | Unix.WSTOPPED s -> Printf.sprintf "Stopped %d" s + in + error "Call '%s %s' exited badly: %s [stdout = '%s'; stderr = '%s']" script + (String.concat " " args) message stdout stderr; + raise (Script_error ["script", script; "args", String.concat " " args; "code", + message; "stdout", stdout; "stderr", stderr]) let call_script ?(log_successful_output=false) ?(timeout=Some 60.0) script args = - let call_script_internal env script args = - let (out,err) = Forkhelpers.execute_command_get_output ~env ?timeout script args in - out - in - check_n_run call_script_internal script args + let call_script_internal env script args = + let (out,err) = Forkhelpers.execute_command_get_output ~env ?timeout script args in + out + in + check_n_run call_script_internal script args let fork_script script args = - let fork_script_internal env script args = - let pid = Forkhelpers.safe_close_and_exec ~env None None None [] script args in - Forkhelpers.dontwaitpid pid; - in - check_n_run fork_script_internal script args + let fork_script_internal env script args = + let pid = Forkhelpers.safe_close_and_exec ~env None None None [] script args in + Forkhelpers.dontwaitpid pid; + in + check_n_run fork_script_internal script args module Sysfs = struct - let list () = - let all = Array.to_list (Sys.readdir "/sys/class/net") in - List.filter (fun name -> Sys.is_directory ("/sys/class/net/" ^ name)) all - - let list_drivers () = - try - Array.to_list (Sys.readdir "/sys/bus/pci/drivers") - with _ -> - warn "Failed to obtain list of drivers from sysfs"; - [] - - let get_driver_version driver () = - try - Some (String.trim (Xapi_stdext_unix.Unixext.string_of_file ("/sys/bus/pci/drivers/" ^ driver ^ "/module/version"))) - with _ -> - warn "Failed to obtain driver version from sysfs"; - None - - let getpath dev attr = - Printf.sprintf "/sys/class/net/%s/%s" dev attr - - let read_one_line file = - try - let inchan = open_in file in - Pervasiveext.finally - (fun () -> input_line inchan) - (fun () -> close_in inchan) - with - | End_of_file -> "" - (* Match the exception when the device state if off *) - | Sys_error("Invalid argument") -> raise (Read_error file) - | exn -> - error "Error in read one line of file: %s, exception %s\n%s" - file (Printexc.to_string exn) (Printexc.get_backtrace ()); - raise (Read_error file) - - let write_one_line file l = - let outchan = open_out file in - try - output_string outchan (l ^ "\n"); - close_out outchan - with exn -> close_out outchan; raise (Write_error file) - - let is_physical name = - try - let devpath = getpath name "device" in - let driver_link = Unix.readlink (devpath ^ "/driver") in - (* filter out symlinks under device/driver which look like /../../../devices/xen-backend/vif- *) - not(List.mem "xen-backend" (Astring.String.cuts ~empty:false ~sep:"/" driver_link)) - with _ -> false - - let get_carrier name = - try - let i = int_of_string (read_one_line (getpath name "carrier")) in - match i with 1 -> true | 0 -> false | _ -> false - with _ -> false - - let get_pcibuspath name = - try - let devpath = Unix.readlink (getpath name "device") in - List.hd (List.rev (Astring.String.cuts ~empty:false ~sep:"/" devpath)) - with exn -> "N/A" - - let get_pci_ids name = - let read_id_from path = - try - let l = read_one_line path in - (* trim 0x *) - String.sub l 2 (String.length l - 2) - with _ -> "" - in - read_id_from (getpath name "device/vendor"), - read_id_from (getpath name "device/device") - - (** Returns the name of the driver for network device [dev] *) - let get_driver_name dev = - try - let driver_path = Unix.readlink (getpath dev "device/driver") in - match Astring.String.cut ~sep:"/" ~rev:true driver_path with - | Some (prefix, suffix) -> Some suffix - | None -> - debug "get %s driver name: %s does not contain slash" dev driver_path; - None - with _ -> - debug "%s: could not read netdev's driver name" dev; - None - - let get_driver_name_err dev = - match get_driver_name dev with - | Some a -> Result.Ok a - | None -> Result.Error (Fail_to_get_driver_name, "Failed to get driver name for: "^ dev) - - (** Returns the features bitmap for the driver for [dev]. - * The features bitmap is a set of NETIF_F_ flags supported by its driver. *) - let get_features dev = - try - Some (int_of_string (read_one_line (getpath dev "features"))) - with _ -> - None - - (** Returns [true] if [dev] supports VLAN acceleration, [false] otherwise. *) - let has_vlan_accel dev = - let flag_NETIF_F_HW_VLAN_TX = 128 in - let flag_NETIF_F_HW_VLAN_RX = 256 in - let flag_NETIF_F_VLAN = flag_NETIF_F_HW_VLAN_TX lor flag_NETIF_F_HW_VLAN_RX in - match get_features dev with - | None -> false - | Some features -> (features land flag_NETIF_F_VLAN) <> 0 - - let set_multicast_snooping bridge value = - try - let path = getpath bridge "bridge/multicast_snooping" in - write_one_line path (if value then "1" else "0") - with _ -> - warn "Could not %s IGMP-snooping on bridge %s" (if value then "enable" else "disable") bridge - - let bridge_to_interfaces bridge = - try - Array.to_list (Sys.readdir (getpath bridge "brif")) - with _ -> [] - - let get_all_bridges () = - let ifaces = list () in - List.filter (fun name -> Sys.file_exists (getpath name "bridge")) ifaces - - (** Returns (speed, duplex) for a given network interface: int megabits/s, Duplex. - * The units of speed are specified in pif_record in xen-api/xapi/records.ml. - * Note: these data are present in sysfs from kernel 2.6.33. *) - let get_status name = - let speed = getpath name "speed" - |> (fun p -> try (read_one_line p |> int_of_string) with _ -> 0) - in - let duplex = getpath name "duplex" - |> (fun p -> try read_one_line p |> duplex_of_string with _ -> Duplex_unknown) - in (speed, duplex) - - let get_dev_nums_with_same_driver driver = - try - Sys.readdir ("/sys/bus/pci/drivers/" ^ driver) - |> Array.to_list - |> List.filter (Re.execp (Re.Perl.compile_pat "\\d+:\\d+:\\d+\\.\\d+")) - |> List.length - with _ -> 0 - - let parent_device_of_vf pcibuspath = - try - let pf_net_path = Printf.sprintf "/sys/bus/pci/devices/%s/physfn/net" pcibuspath in - let devices = Sys.readdir pf_net_path in - Result.Ok devices.(0) - with _ -> Result.Error (Parent_device_of_vf_not_found, "Can not get parent device for " ^ pcibuspath) - - let get_child_vfs_sysfs_paths dev = - try - let device_path = getpath dev "device" in - Result. Ok ( - Sys.readdir device_path - |> Array.to_list - |> List.filter (Re.execp (Re.Perl.compile_pat "virtfn(\\d+)")) (* List elements are like "virtfn1" *) - |> List.map (Filename.concat device_path) - ) - with _ -> Result.Error (Vf_sysfs_path_not_found, "Can not get child vfs sysfs paths for " ^ dev) - - let device_index_of_vf parent_dev pcibuspath = - try - let open Rresult.R.Infix in - get_child_vfs_sysfs_paths parent_dev >>= fun paths -> - let group = - List.find (fun x -> Astring.String.is_infix ~affix:pcibuspath (Unix.readlink x)) paths - |> Re.exec_opt (Re.Perl.compile_pat "virtfn(\\d+)") - in - match group with - | None -> Result.Error (Vf_index_not_found, "Can not get device index for " ^ pcibuspath) - | Some x -> Ok (int_of_string (Re.Group.get x 1)) - with _ -> Result.Error (Vf_index_not_found, "Can not get device index for " ^ pcibuspath) - - let unbind_child_vfs dev = - let open Rresult.R.Infix in - let unbind vf_path = - let driver_name = - try - Unix.readlink (Filename.concat vf_path "driver") - |> Filename.basename - with _ -> "" - and vf_pcibuspath = - Unix.readlink vf_path - |> Filename.basename - in - if driver_name = "" then Result.Ok () (* not bind to any driver, Ok *) - else begin - debug "unbinding %s from driver %s at %s" vf_path driver_name vf_pcibuspath; - let unbind_interface = Filename.concat vf_path "driver/unbind" - and remove_slot_interface = Filename.concat vf_path "driver/remove_slot" in - begin try - write_one_line remove_slot_interface vf_pcibuspath - with _ -> () - end; - try - write_one_line unbind_interface vf_pcibuspath; Result.Ok () - with _ -> Result.Error (Fail_to_unbind_from_driver, Printf.sprintf "%s: VF Fail to be unbound from driver %s" vf_path driver_name) - end - in - get_child_vfs_sysfs_paths dev >>= fun paths -> - List.fold_left (>>=) (Ok ()) (List.map (fun x -> fun _ -> unbind x) paths) - - let get_sriov_numvfs dev = - try - getpath dev "device/sriov_numvfs" - |> read_one_line - |> String.trim - |> int_of_string - with _ -> 0 - - let get_sriov_maxvfs dev = - try - Ok (getpath dev "device/sriov_totalvfs" - |> read_one_line - |> String.trim - |> int_of_string) - with _ -> Error (Fail_to_get_maxvfs, "Failed to get maxvfs from sysfs interface for device: " ^ dev) - - let set_sriov_numvfs dev num_vfs = - let interface = getpath dev "device/sriov_numvfs" in - try - write_one_line interface (string_of_int num_vfs); - if get_sriov_numvfs dev = num_vfs then Result.Ok () - else Result.Error (Other, "Error: set SR-IOV error on " ^ dev) - with - | Sys_error s when Astring.String.is_infix ~affix:"out of range of" s -> - Result.Error (Bus_out_of_range, "Error: bus out of range when setting SR-IOV numvfs on " ^ dev) - | Sys_error s when Astring.String.is_infix ~affix:"not enough MMIO resources" s -> - Result.Error (Not_enough_mmio_resources, "Error: not enough mmio resources when setting SR-IOV numvfs on " ^ dev) - | e -> - let msg = Printf.sprintf "Error: set SR-IOV numvfs error with exception %s on %s" (Printexc.to_string e) dev in - Result.Error (Other, msg) + let list () = + let all = Array.to_list (Sys.readdir "/sys/class/net") in + List.filter (fun name -> Sys.is_directory ("/sys/class/net/" ^ name)) all + + let list_drivers () = + try + Array.to_list (Sys.readdir "/sys/bus/pci/drivers") + with _ -> + warn "Failed to obtain list of drivers from sysfs"; + [] + + let get_driver_version driver () = + try + Some (String.trim (Xapi_stdext_unix.Unixext.string_of_file ("/sys/bus/pci/drivers/" ^ driver ^ "/module/version"))) + with _ -> + warn "Failed to obtain driver version from sysfs"; + None + + let getpath dev attr = + Printf.sprintf "/sys/class/net/%s/%s" dev attr + + let read_one_line file = + try + let inchan = open_in file in + Pervasiveext.finally + (fun () -> input_line inchan) + (fun () -> close_in inchan) + with + | End_of_file -> "" + (* Match the exception when the device state if off *) + | Sys_error("Invalid argument") -> raise (Read_error file) + | exn -> + error "Error in read one line of file: %s, exception %s\n%s" + file (Printexc.to_string exn) (Printexc.get_backtrace ()); + raise (Read_error file) + + let write_one_line file l = + let outchan = open_out file in + try + output_string outchan (l ^ "\n"); + close_out outchan + with exn -> close_out outchan; raise (Write_error file) + + let is_physical name = + try + let devpath = getpath name "device" in + let driver_link = Unix.readlink (devpath ^ "/driver") in + (* filter out symlinks under device/driver which look like /../../../devices/xen-backend/vif- *) + not(List.mem "xen-backend" (Astring.String.cuts ~empty:false ~sep:"/" driver_link)) + with _ -> false + + let get_carrier name = + try + let i = int_of_string (read_one_line (getpath name "carrier")) in + match i with 1 -> true | 0 -> false | _ -> false + with _ -> false + + let get_pcibuspath name = + try + let devpath = Unix.readlink (getpath name "device") in + List.hd (List.rev (Astring.String.cuts ~empty:false ~sep:"/" devpath)) + with exn -> "N/A" + + let get_pci_ids name = + let read_id_from path = + try + let l = read_one_line path in + (* trim 0x *) + String.sub l 2 (String.length l - 2) + with _ -> "" + in + read_id_from (getpath name "device/vendor"), + read_id_from (getpath name "device/device") + + (** Returns the name of the driver for network device [dev] *) + let get_driver_name dev = + try + let driver_path = Unix.readlink (getpath dev "device/driver") in + match Astring.String.cut ~sep:"/" ~rev:true driver_path with + | Some (prefix, suffix) -> Some suffix + | None -> + debug "get %s driver name: %s does not contain slash" dev driver_path; + None + with _ -> + debug "%s: could not read netdev's driver name" dev; + None + + let get_driver_name_err dev = + match get_driver_name dev with + | Some a -> Result.Ok a + | None -> Result.Error (Fail_to_get_driver_name, "Failed to get driver name for: "^ dev) + + (** Returns the features bitmap for the driver for [dev]. + * The features bitmap is a set of NETIF_F_ flags supported by its driver. *) + let get_features dev = + try + Some (int_of_string (read_one_line (getpath dev "features"))) + with _ -> + None + + (** Returns [true] if [dev] supports VLAN acceleration, [false] otherwise. *) + let has_vlan_accel dev = + let flag_NETIF_F_HW_VLAN_TX = 128 in + let flag_NETIF_F_HW_VLAN_RX = 256 in + let flag_NETIF_F_VLAN = flag_NETIF_F_HW_VLAN_TX lor flag_NETIF_F_HW_VLAN_RX in + match get_features dev with + | None -> false + | Some features -> (features land flag_NETIF_F_VLAN) <> 0 + + let set_multicast_snooping bridge value = + try + let path = getpath bridge "bridge/multicast_snooping" in + write_one_line path (if value then "1" else "0") + with _ -> + warn "Could not %s IGMP-snooping on bridge %s" (if value then "enable" else "disable") bridge + + let bridge_to_interfaces bridge = + try + Array.to_list (Sys.readdir (getpath bridge "brif")) + with _ -> [] + + let get_all_bridges () = + let ifaces = list () in + List.filter (fun name -> Sys.file_exists (getpath name "bridge")) ifaces + + (** Returns (speed, duplex) for a given network interface: int megabits/s, Duplex. + * The units of speed are specified in pif_record in xen-api/xapi/records.ml. + * Note: these data are present in sysfs from kernel 2.6.33. *) + let get_status name = + let speed = getpath name "speed" + |> (fun p -> try (read_one_line p |> int_of_string) with _ -> 0) + in + let duplex = getpath name "duplex" + |> (fun p -> try read_one_line p |> duplex_of_string with _ -> Duplex_unknown) + in (speed, duplex) + + let get_dev_nums_with_same_driver driver = + try + Sys.readdir ("/sys/bus/pci/drivers/" ^ driver) + |> Array.to_list + |> List.filter (Re.execp (Re.Perl.compile_pat "\\d+:\\d+:\\d+\\.\\d+")) + |> List.length + with _ -> 0 + + let parent_device_of_vf pcibuspath = + try + let pf_net_path = Printf.sprintf "/sys/bus/pci/devices/%s/physfn/net" pcibuspath in + let devices = Sys.readdir pf_net_path in + Result.Ok devices.(0) + with _ -> Result.Error (Parent_device_of_vf_not_found, "Can not get parent device for " ^ pcibuspath) + + let get_child_vfs_sysfs_paths dev = + try + let device_path = getpath dev "device" in + Result. Ok ( + Sys.readdir device_path + |> Array.to_list + |> List.filter (Re.execp (Re.Perl.compile_pat "virtfn(\\d+)")) (* List elements are like "virtfn1" *) + |> List.map (Filename.concat device_path) + ) + with _ -> Result.Error (Vf_sysfs_path_not_found, "Can not get child vfs sysfs paths for " ^ dev) + + let device_index_of_vf parent_dev pcibuspath = + try + let open Rresult.R.Infix in + get_child_vfs_sysfs_paths parent_dev >>= fun paths -> + let group = + List.find (fun x -> Astring.String.is_infix ~affix:pcibuspath (Unix.readlink x)) paths + |> Re.exec_opt (Re.Perl.compile_pat "virtfn(\\d+)") + in + match group with + | None -> Result.Error (Vf_index_not_found, "Can not get device index for " ^ pcibuspath) + | Some x -> Ok (int_of_string (Re.Group.get x 1)) + with _ -> Result.Error (Vf_index_not_found, "Can not get device index for " ^ pcibuspath) + + let unbind_child_vfs dev = + let open Rresult.R.Infix in + let unbind vf_path = + let driver_name = + try + Unix.readlink (Filename.concat vf_path "driver") + |> Filename.basename + with _ -> "" + and vf_pcibuspath = + Unix.readlink vf_path + |> Filename.basename + in + if driver_name = "" then Result.Ok () (* not bind to any driver, Ok *) + else begin + debug "unbinding %s from driver %s at %s" vf_path driver_name vf_pcibuspath; + let unbind_interface = Filename.concat vf_path "driver/unbind" + and remove_slot_interface = Filename.concat vf_path "driver/remove_slot" in + begin try + write_one_line remove_slot_interface vf_pcibuspath + with _ -> () + end; + try + write_one_line unbind_interface vf_pcibuspath; Result.Ok () + with _ -> Result.Error (Fail_to_unbind_from_driver, Printf.sprintf "%s: VF Fail to be unbound from driver %s" vf_path driver_name) + end + in + get_child_vfs_sysfs_paths dev >>= fun paths -> + List.fold_left (>>=) (Ok ()) (List.map (fun x -> fun _ -> unbind x) paths) + + let get_sriov_numvfs dev = + try + getpath dev "device/sriov_numvfs" + |> read_one_line + |> String.trim + |> int_of_string + with _ -> 0 + + let get_sriov_maxvfs dev = + try + Ok (getpath dev "device/sriov_totalvfs" + |> read_one_line + |> String.trim + |> int_of_string) + with _ -> Error (Fail_to_get_maxvfs, "Failed to get maxvfs from sysfs interface for device: " ^ dev) + + let set_sriov_numvfs dev num_vfs = + let interface = getpath dev "device/sriov_numvfs" in + try + write_one_line interface (string_of_int num_vfs); + if get_sriov_numvfs dev = num_vfs then Result.Ok () + else Result.Error (Other, "Error: set SR-IOV error on " ^ dev) + with + | Sys_error s when Astring.String.is_infix ~affix:"out of range of" s -> + Result.Error (Bus_out_of_range, "Error: bus out of range when setting SR-IOV numvfs on " ^ dev) + | Sys_error s when Astring.String.is_infix ~affix:"not enough MMIO resources" s -> + Result.Error (Not_enough_mmio_resources, "Error: not enough mmio resources when setting SR-IOV numvfs on " ^ dev) + | e -> + let msg = Printf.sprintf "Error: set SR-IOV numvfs error with exception %s on %s" (Printexc.to_string e) dev in + Result.Error (Other, msg) end module Ip = struct - type ipversion = V4 | V6 | V46 - - let string_of_version = function - | V4 -> ["-4"] - | V6 -> ["-6"] - | V46 -> [] - - let call ?(log=false) args = - call_script ~log_successful_output:log iproute2 args - - let find output attr = -info "Looking for %s in [%s]" attr output; - let args = Astring.String.fields ~empty:false output in - let indices = (Xapi_stdext_std.Listext.List.position (fun s -> s = attr) args) in -info "Found at [ %s ]" (String.concat ", " (List.map string_of_int indices)); - List.map (fun i -> List.nth args (succ i)) indices - - let get_link_flags dev = - let output = call ["link"; "show"; "dev"; dev] in - let i = String.index output '<' in - let j = String.index output '>' in - let flags = String.sub output (i + 1) (j - i - 1) in - Astring.String.cuts ~empty:false ~sep:"," flags - - let is_up dev = - try - List.mem "UP" (get_link_flags dev) - with _ -> false - - let link_set dev args = - ignore (call ~log:true ("link" :: "set" :: dev :: args)) - - let link_set_mtu dev mtu = - try ignore (link_set dev ["mtu"; string_of_int mtu]) - with e -> error "MTU size is not supported: %s" (string_of_int mtu) - - let link_set_up dev = - link_set dev ["up"] - - let link_set_down dev = - if is_up dev then - link_set dev ["down"] - - let with_links_down devs f = - let up_links = List.filter (fun dev -> is_up dev) devs in - List.iter (fun dev -> link_set dev ["down"]) up_links; - Pervasiveext.finally - f - (fun () -> List.iter link_set_up up_links) - - let link ?(version=V46) dev attr = - let v = string_of_version version in - let output = call (v @ ["link"; "show"; "dev"; dev]) in - find output attr - - let addr ?(version=V46) dev attr = - let v = string_of_version version in - let output = call (v @ ["addr"; "show"; "dev"; dev]) in - find output attr - - let get_mtu dev = - int_of_string (List.hd (link dev "mtu")) - - let get_state dev = - match addr dev "state" with - | "UP" :: _ -> true - | _ -> false - - let get_mac dev = - List.hd (link dev "link/ether") - - let set_mac dev mac = - try - ignore (link_set dev ["address"; mac]) - with _ -> () - - let split_addr addr = - match Astring.String.cut ~sep:"/" addr with - | Some (ipstr, prefixlenstr) -> - let ip = Unix.inet_addr_of_string ipstr in - let prefixlen = int_of_string prefixlenstr in - Some (ip, prefixlen) - | None -> None - - (* see http://en.wikipedia.org/wiki/IPv6_address#Modified_EUI-64 *) - let get_ipv6_interface_id dev = - let mac = get_mac dev in - let bytes = List.map (fun byte -> int_of_string ("0x" ^ byte)) (Astring.String.cuts ~empty:false ~sep:":" mac) in - let rec modified_bytes ac i = function - | [] -> - ac - | head :: tail -> - if i = 0 then - let head' = head lxor 2 in - modified_bytes (head' :: ac) 1 tail - else if i = 2 then - modified_bytes (254 :: 255 :: head :: ac) 3 tail - else - modified_bytes (head :: ac) (i + 1) tail - in - let bytes' = List.rev (modified_bytes [] 0 bytes) in - [0; 0; 0; 0; 0; 0; 0; 0] @ bytes' - - let get_ipv6_link_local_addr dev = - let id = get_ipv6_interface_id dev in - let link_local = 0xfe :: 0x80 :: (List.tl (List.tl id)) in - let rec to_string ac i = function - | [] -> ac - | hd :: tl -> - let separator = - if i = 0 || i mod 2 = 1 then - "" - else - ":" - in - let ac' = ac ^ separator ^ Printf.sprintf "%02x" hd in - to_string ac' (i + 1) tl - in - to_string "" 0 link_local ^ "/64" - - let get_ipv4 dev = - let addrs = addr dev "inet" in - Xapi_stdext_std.Listext.List.filter_map split_addr addrs - - let get_ipv6 dev = - let addrs = addr dev "inet6" in - Xapi_stdext_std.Listext.List.filter_map split_addr addrs - - let set_ip_addr dev (ip, prefixlen) = - let addr = Printf.sprintf "%s/%d" (Unix.string_of_inet_addr ip) prefixlen in - let broadcast = - (* Set the broadcast address when adding an IPv4 address *) - if String.contains addr '.' then - ["broadcast"; "+"] - else [] - in - try - ignore (call ~log:true (["addr"; "add"; addr; "dev"; dev] @ broadcast)) - with _ -> () - - let set_ipv6_link_local_addr dev = - let addr = get_ipv6_link_local_addr dev in - try - ignore (call ~log:true ["addr"; "add"; addr; "dev"; dev; "scope"; "link"]) - with _ -> () - - let flush_ip_addr ?(ipv6=false) dev = - try - let mode = if ipv6 then "-6" else "-4" in - ignore (call ~log:true [mode; "addr"; "flush"; "dev"; dev]) - with _ -> () - - let del_ip_addr dev (ip, prefixlen) = - let addr = Printf.sprintf "%s/%d" (Unix.string_of_inet_addr ip) prefixlen in - try - ignore (call ~log:true ["addr"; "del"; addr; "dev"; dev]) - with _ -> () - - let route_show ?(version=V46) dev = - let v = string_of_version version in - call (v @ ["route"; "show"; "dev"; dev]) - - let set_route ?network dev gateway = - try - match network with - | None -> - ignore (call ~log:true ["route"; "replace"; "default"; "via"; Unix.string_of_inet_addr gateway; "dev"; dev]) - | Some (ip, prefixlen) -> - let addr = Printf.sprintf "%s/%d" (Unix.string_of_inet_addr ip) prefixlen in - ignore (call ~log:true ["route"; "replace"; addr; "via"; Unix.string_of_inet_addr gateway; "dev"; dev]) - with _ -> () - - let set_gateway dev gateway = set_route dev gateway - - let vlan_name interface vlan = - Printf.sprintf "%s.%d" interface vlan - - let create_vlan interface vlan = - if not (List.mem (vlan_name interface vlan) (Sysfs.list ())) then - ignore (call ~log:true ["link"; "add"; "link"; interface; "name"; vlan_name interface vlan; - "type"; "vlan"; "id"; string_of_int vlan]) - - let destroy_vlan name = - if List.mem name (Sysfs.list ()) then - ignore (call ~log:true ["link"; "delete"; name]) - - let set_vf_mac dev index mac = - try - debug "Setting VF MAC address for dev: %s, index: %d, MAC: %s" dev index mac; - Result.Ok (link_set dev ["vf"; string_of_int index; "mac"; mac]) - with _ -> Result.Error (Fail_to_set_vf_mac, "Failed to set VF MAC for: " ^ dev) - - let set_vf_vlan dev index vlan = - try - debug "Setting VF VLAN for dev: %s, index: %d, VLAN: %d" dev index vlan; - Result.Ok (link_set dev ["vf"; string_of_int index; "vlan"; string_of_int vlan]) - with _ -> Result.Error (Fail_to_set_vf_vlan, "Failed to set VF VLAN for: " ^ dev) - - (* We know some NICs do not support config VF Rate, so will explicitly tell XAPI this error*) - let set_vf_rate dev index rate = - try - debug "Setting VF rate for dev: %s, index: %d, rate: %d" dev index rate; - Result.Ok (link_set dev ["vf"; string_of_int index; "rate"; string_of_int rate]) - with _ -> Result.Error (Fail_to_set_vf_rate, "Failed to set VF rate for: " ^ dev) + type ipversion = V4 | V6 | V46 + + let string_of_version = function + | V4 -> ["-4"] + | V6 -> ["-6"] + | V46 -> [] + + let call ?(log=false) args = + call_script ~log_successful_output:log iproute2 args + + let find output attr = + info "Looking for %s in [%s]" attr output; + let args = Astring.String.fields ~empty:false output in + let indices = (Xapi_stdext_std.Listext.List.position (fun s -> s = attr) args) in + info "Found at [ %s ]" (String.concat ", " (List.map string_of_int indices)); + List.map (fun i -> List.nth args (succ i)) indices + + let get_link_flags dev = + let output = call ["link"; "show"; "dev"; dev] in + let i = String.index output '<' in + let j = String.index output '>' in + let flags = String.sub output (i + 1) (j - i - 1) in + Astring.String.cuts ~empty:false ~sep:"," flags + + let is_up dev = + try + List.mem "UP" (get_link_flags dev) + with _ -> false + + let link_set dev args = + ignore (call ~log:true ("link" :: "set" :: dev :: args)) + + let link_set_mtu dev mtu = + try ignore (link_set dev ["mtu"; string_of_int mtu]) + with e -> error "MTU size is not supported: %s" (string_of_int mtu) + + let link_set_up dev = + link_set dev ["up"] + + let link_set_down dev = + if is_up dev then + link_set dev ["down"] + + let with_links_down devs f = + let up_links = List.filter (fun dev -> is_up dev) devs in + List.iter (fun dev -> link_set dev ["down"]) up_links; + Pervasiveext.finally + f + (fun () -> List.iter link_set_up up_links) + + let link ?(version=V46) dev attr = + let v = string_of_version version in + let output = call (v @ ["link"; "show"; "dev"; dev]) in + find output attr + + let addr ?(version=V46) dev attr = + let v = string_of_version version in + let output = call (v @ ["addr"; "show"; "dev"; dev]) in + find output attr + + let get_mtu dev = + int_of_string (List.hd (link dev "mtu")) + + let get_state dev = + match addr dev "state" with + | "UP" :: _ -> true + | _ -> false + + let get_mac dev = + List.hd (link dev "link/ether") + + let set_mac dev mac = + try + ignore (link_set dev ["address"; mac]) + with _ -> () + + let split_addr addr = + match Astring.String.cut ~sep:"/" addr with + | Some (ipstr, prefixlenstr) -> + let ip = Unix.inet_addr_of_string ipstr in + let prefixlen = int_of_string prefixlenstr in + Some (ip, prefixlen) + | None -> None + + (* see http://en.wikipedia.org/wiki/IPv6_address#Modified_EUI-64 *) + let get_ipv6_interface_id dev = + let mac = get_mac dev in + let bytes = List.map (fun byte -> int_of_string ("0x" ^ byte)) (Astring.String.cuts ~empty:false ~sep:":" mac) in + let rec modified_bytes ac i = function + | [] -> + ac + | head :: tail -> + if i = 0 then + let head' = head lxor 2 in + modified_bytes (head' :: ac) 1 tail + else if i = 2 then + modified_bytes (254 :: 255 :: head :: ac) 3 tail + else + modified_bytes (head :: ac) (i + 1) tail + in + let bytes' = List.rev (modified_bytes [] 0 bytes) in + [0; 0; 0; 0; 0; 0; 0; 0] @ bytes' + + let get_ipv6_link_local_addr dev = + let id = get_ipv6_interface_id dev in + let link_local = 0xfe :: 0x80 :: (List.tl (List.tl id)) in + let rec to_string ac i = function + | [] -> ac + | hd :: tl -> + let separator = + if i = 0 || i mod 2 = 1 then + "" + else + ":" + in + let ac' = ac ^ separator ^ Printf.sprintf "%02x" hd in + to_string ac' (i + 1) tl + in + to_string "" 0 link_local ^ "/64" + + let get_ipv4 dev = + let addrs = addr dev "inet" in + Xapi_stdext_std.Listext.List.filter_map split_addr addrs + + let get_ipv6 dev = + let addrs = addr dev "inet6" in + Xapi_stdext_std.Listext.List.filter_map split_addr addrs + + let set_ip_addr dev (ip, prefixlen) = + let addr = Printf.sprintf "%s/%d" (Unix.string_of_inet_addr ip) prefixlen in + let broadcast = + (* Set the broadcast address when adding an IPv4 address *) + if String.contains addr '.' then + ["broadcast"; "+"] + else [] + in + try + ignore (call ~log:true (["addr"; "add"; addr; "dev"; dev] @ broadcast)) + with _ -> () + + let set_ipv6_link_local_addr dev = + let addr = get_ipv6_link_local_addr dev in + try + ignore (call ~log:true ["addr"; "add"; addr; "dev"; dev; "scope"; "link"]) + with _ -> () + + let flush_ip_addr ?(ipv6=false) dev = + try + let mode = if ipv6 then "-6" else "-4" in + ignore (call ~log:true [mode; "addr"; "flush"; "dev"; dev]) + with _ -> () + + let del_ip_addr dev (ip, prefixlen) = + let addr = Printf.sprintf "%s/%d" (Unix.string_of_inet_addr ip) prefixlen in + try + ignore (call ~log:true ["addr"; "del"; addr; "dev"; dev]) + with _ -> () + + let route_show ?(version=V46) dev = + let v = string_of_version version in + call (v @ ["route"; "show"; "dev"; dev]) + + let set_route ?network dev gateway = + try + match network with + | None -> + ignore (call ~log:true ["route"; "replace"; "default"; "via"; Unix.string_of_inet_addr gateway; "dev"; dev]) + | Some (ip, prefixlen) -> + let addr = Printf.sprintf "%s/%d" (Unix.string_of_inet_addr ip) prefixlen in + ignore (call ~log:true ["route"; "replace"; addr; "via"; Unix.string_of_inet_addr gateway; "dev"; dev]) + with _ -> () + + let set_gateway dev gateway = set_route dev gateway + + let vlan_name interface vlan = + Printf.sprintf "%s.%d" interface vlan + + let create_vlan interface vlan = + if not (List.mem (vlan_name interface vlan) (Sysfs.list ())) then + ignore (call ~log:true ["link"; "add"; "link"; interface; "name"; vlan_name interface vlan; + "type"; "vlan"; "id"; string_of_int vlan]) + + let destroy_vlan name = + if List.mem name (Sysfs.list ()) then + ignore (call ~log:true ["link"; "delete"; name]) + + let set_vf_mac dev index mac = + try + debug "Setting VF MAC address for dev: %s, index: %d, MAC: %s" dev index mac; + Result.Ok (link_set dev ["vf"; string_of_int index; "mac"; mac]) + with _ -> Result.Error (Fail_to_set_vf_mac, "Failed to set VF MAC for: " ^ dev) + + let set_vf_vlan dev index vlan = + try + debug "Setting VF VLAN for dev: %s, index: %d, VLAN: %d" dev index vlan; + Result.Ok (link_set dev ["vf"; string_of_int index; "vlan"; string_of_int vlan]) + with _ -> Result.Error (Fail_to_set_vf_vlan, "Failed to set VF VLAN for: " ^ dev) + + (* We know some NICs do not support config VF Rate, so will explicitly tell XAPI this error*) + let set_vf_rate dev index rate = + try + debug "Setting VF rate for dev: %s, index: %d, rate: %d" dev index rate; + Result.Ok (link_set dev ["vf"; string_of_int index; "rate"; string_of_int rate]) + with _ -> Result.Error (Fail_to_set_vf_rate, "Failed to set VF rate for: " ^ dev) end module Linux_bonding = struct - let bonding_masters = "/sys/class/net/bonding_masters" - - let load_bonding_driver () = - debug "Loading bonding driver"; - try - ignore (call_script modprobe ["bonding"]); - (* is_bond_device() uses the contents of sysfs_bonding_masters to work out which devices - * have already been created. Unfortunately the driver creates "bond0" automatically at - * modprobe init. Get rid of this now or our accounting will go wrong. *) - Sysfs.write_one_line bonding_masters "-bond0" - with _ -> - error "Failed to load bonding driver" - - let bonding_driver_loaded () = - try - Unix.access bonding_masters [Unix.F_OK]; - true - with _ -> - false - - let is_bond_device name = - try - List.exists ((=) name) (Astring.String.cuts ~empty:false ~sep:" " (Sysfs.read_one_line bonding_masters)) - with _ -> false - - (** Ensures that a bond master device exists in the kernel. *) - let add_bond_master name = - if not (bonding_driver_loaded ()) then - load_bonding_driver (); - if is_bond_device name then - debug "Bond master %s already exists, not creating" name - else begin - debug "Adding bond master %s" name; - try - Sysfs.write_one_line bonding_masters ("+" ^ name) - with _ -> - error "Failed to add bond master %s" name - end - - (** No, Mr. Bond, I expect you to die. *) - let remove_bond_master name = - if is_bond_device name then begin - let rec destroy retries = - debug "Removing bond master %s (%d attempts remain)" name retries; - try - Sysfs.write_one_line bonding_masters ("-" ^ name) - with _ -> - if retries > 0 then - (Thread.delay 0.5; destroy (retries - 1)) - else - error "Failed to remove bond master %s" name - in - destroy 10 - end else - error "Bond master %s does not exist; cannot destroy it" name - - let get_bond_slaves master = - let path = Sysfs.getpath master "bonding/slaves" in - let slaves = Sysfs.read_one_line path in - if slaves = "" then - [] - else - Astring.String.cuts ~empty:false ~sep:" " slaves - - let add_bond_slaves master slaves = - List.iter (fun slave -> - debug "Adding slave %s to bond %s" slave master; - try - Sysfs.write_one_line (Sysfs.getpath master "bonding/slaves") ("+" ^ slave) - with _ -> - error "Failed to add slave %s to bond %s" slave master - ) slaves - - let remove_bond_slaves master slaves = - List.iter (fun slave -> - debug "Removing slave %s from bond %s" slave master; - try - Sysfs.write_one_line (Sysfs.getpath master "bonding/slaves") ("-" ^ slave) - with _ -> - error "Failed to remove slave %s from bond %s" slave master - ) slaves - - let set_bond_slaves master slaves = - if is_bond_device master then - let current_slaves = get_bond_slaves master in - let slaves_to_remove = Xapi_stdext_std.Listext.List.set_difference current_slaves slaves in - let slaves_to_add = Xapi_stdext_std.Listext.List.set_difference slaves current_slaves in - Ip.with_links_down (slaves_to_add @ slaves_to_remove) (fun () -> - remove_bond_slaves master slaves_to_remove; - add_bond_slaves master slaves_to_add - ) - else - error "Bond %s does not exist; cannot set slaves" master - - let with_slaves_removed master f = - if is_bond_device master then - try - let slaves = get_bond_slaves master in - Ip.with_links_down slaves (fun () -> - remove_bond_slaves master slaves; - Pervasiveext.finally - f - (fun () -> add_bond_slaves master slaves) - ) - with _ -> - error "Failed to remove or re-add slaves from bond %s" master - else - error "Bond %s does not exist; cannot remove/add slaves" master - - let get_bond_master_of slave = - try - let master_symlink = Sysfs.getpath slave "master" in - let master_path = Unix.readlink master_symlink in - let slaves_path = Filename.concat master_symlink "bonding/slaves" in - Unix.access slaves_path [ Unix.F_OK ]; - Some (List.hd (List.rev (Astring.String.cuts ~empty:false ~sep:"/" master_path))) - with _ -> None - - let get_bond_active_slave master = - try - Some (Sysfs.read_one_line (Sysfs.getpath master ("bonding/active_slave"))) - with _ -> - error "Failed to get active_slave of bond %s" master; - None - - let known_props = ["mode"; "updelay"; "downdelay"; "miimon"; "use_carrier"] - - let get_bond_properties master = - if is_bond_device master then begin - let get_prop prop = - try - let bond_prop = Sysfs.read_one_line (Sysfs.getpath master ("bonding/" ^ prop)) in - if prop = "mode" then - Some (prop, List.hd (Astring.String.cuts ~empty:false ~sep:" " bond_prop)) - else Some (prop, bond_prop) - with _ -> - debug "Failed to get property \"%s\" on bond %s" prop master; - None - in - Xapi_stdext_std.Listext.List.filter_map get_prop known_props - end else begin - debug "Bond %s does not exist; cannot get properties" master; - [] - end - - let set_bond_properties master properties = - if is_bond_device master then begin - let current_props = get_bond_properties master in - debug "Current bond properties: %s" (String.concat ", " (List.map (fun (k, v) -> k ^ "=" ^ v) current_props)); - (* Find out which properties are known, but different from the current state, - * and only continue if there is at least one of those. *) - let props_to_update = List.filter (fun (prop, value) -> - not (List.mem (prop, value) current_props) && List.mem prop known_props) properties in - debug "Bond properties to update: %s" (String.concat ", " (List.map (fun (k, v) -> k ^ "=" ^ v) props_to_update)); - if props_to_update <> [] then - let set_prop (prop, value) = - try - debug "Setting %s=%s on bond %s" prop value master; - Sysfs.write_one_line (Sysfs.getpath master ("bonding/" ^ prop)) value - with _ -> - error "Failed to set property \"%s\" on bond %s" prop master - in - Ip.with_links_down [master] (fun () -> - with_slaves_removed master (fun () -> - List.iter set_prop props_to_update - ) - ) - end else - error "Bond %s does not exist; cannot set properties" master + let bonding_masters = "/sys/class/net/bonding_masters" + + let load_bonding_driver () = + debug "Loading bonding driver"; + try + ignore (call_script modprobe ["bonding"]); + (* is_bond_device() uses the contents of sysfs_bonding_masters to work out which devices + * have already been created. Unfortunately the driver creates "bond0" automatically at + * modprobe init. Get rid of this now or our accounting will go wrong. *) + Sysfs.write_one_line bonding_masters "-bond0" + with _ -> + error "Failed to load bonding driver" + + let bonding_driver_loaded () = + try + Unix.access bonding_masters [Unix.F_OK]; + true + with _ -> + false + + let is_bond_device name = + try + List.exists ((=) name) (Astring.String.cuts ~empty:false ~sep:" " (Sysfs.read_one_line bonding_masters)) + with _ -> false + + (** Ensures that a bond master device exists in the kernel. *) + let add_bond_master name = + if not (bonding_driver_loaded ()) then + load_bonding_driver (); + if is_bond_device name then + debug "Bond master %s already exists, not creating" name + else begin + debug "Adding bond master %s" name; + try + Sysfs.write_one_line bonding_masters ("+" ^ name) + with _ -> + error "Failed to add bond master %s" name + end + + (** No, Mr. Bond, I expect you to die. *) + let remove_bond_master name = + if is_bond_device name then begin + let rec destroy retries = + debug "Removing bond master %s (%d attempts remain)" name retries; + try + Sysfs.write_one_line bonding_masters ("-" ^ name) + with _ -> + if retries > 0 then + (Thread.delay 0.5; destroy (retries - 1)) + else + error "Failed to remove bond master %s" name + in + destroy 10 + end else + error "Bond master %s does not exist; cannot destroy it" name + + let get_bond_slaves master = + let path = Sysfs.getpath master "bonding/slaves" in + let slaves = Sysfs.read_one_line path in + if slaves = "" then + [] + else + Astring.String.cuts ~empty:false ~sep:" " slaves + + let add_bond_slaves master slaves = + List.iter (fun slave -> + debug "Adding slave %s to bond %s" slave master; + try + Sysfs.write_one_line (Sysfs.getpath master "bonding/slaves") ("+" ^ slave) + with _ -> + error "Failed to add slave %s to bond %s" slave master + ) slaves + + let remove_bond_slaves master slaves = + List.iter (fun slave -> + debug "Removing slave %s from bond %s" slave master; + try + Sysfs.write_one_line (Sysfs.getpath master "bonding/slaves") ("-" ^ slave) + with _ -> + error "Failed to remove slave %s from bond %s" slave master + ) slaves + + let set_bond_slaves master slaves = + if is_bond_device master then + let current_slaves = get_bond_slaves master in + let slaves_to_remove = Xapi_stdext_std.Listext.List.set_difference current_slaves slaves in + let slaves_to_add = Xapi_stdext_std.Listext.List.set_difference slaves current_slaves in + Ip.with_links_down (slaves_to_add @ slaves_to_remove) (fun () -> + remove_bond_slaves master slaves_to_remove; + add_bond_slaves master slaves_to_add + ) + else + error "Bond %s does not exist; cannot set slaves" master + + let with_slaves_removed master f = + if is_bond_device master then + try + let slaves = get_bond_slaves master in + Ip.with_links_down slaves (fun () -> + remove_bond_slaves master slaves; + Pervasiveext.finally + f + (fun () -> add_bond_slaves master slaves) + ) + with _ -> + error "Failed to remove or re-add slaves from bond %s" master + else + error "Bond %s does not exist; cannot remove/add slaves" master + + let get_bond_master_of slave = + try + let master_symlink = Sysfs.getpath slave "master" in + let master_path = Unix.readlink master_symlink in + let slaves_path = Filename.concat master_symlink "bonding/slaves" in + Unix.access slaves_path [ Unix.F_OK ]; + Some (List.hd (List.rev (Astring.String.cuts ~empty:false ~sep:"/" master_path))) + with _ -> None + + let get_bond_active_slave master = + try + Some (Sysfs.read_one_line (Sysfs.getpath master ("bonding/active_slave"))) + with _ -> + error "Failed to get active_slave of bond %s" master; + None + + let known_props = ["mode"; "updelay"; "downdelay"; "miimon"; "use_carrier"] + + let get_bond_properties master = + if is_bond_device master then begin + let get_prop prop = + try + let bond_prop = Sysfs.read_one_line (Sysfs.getpath master ("bonding/" ^ prop)) in + if prop = "mode" then + Some (prop, List.hd (Astring.String.cuts ~empty:false ~sep:" " bond_prop)) + else Some (prop, bond_prop) + with _ -> + debug "Failed to get property \"%s\" on bond %s" prop master; + None + in + Xapi_stdext_std.Listext.List.filter_map get_prop known_props + end else begin + debug "Bond %s does not exist; cannot get properties" master; + [] + end + + let set_bond_properties master properties = + if is_bond_device master then begin + let current_props = get_bond_properties master in + debug "Current bond properties: %s" (String.concat ", " (List.map (fun (k, v) -> k ^ "=" ^ v) current_props)); + (* Find out which properties are known, but different from the current state, + * and only continue if there is at least one of those. *) + let props_to_update = List.filter (fun (prop, value) -> + not (List.mem (prop, value) current_props) && List.mem prop known_props) properties in + debug "Bond properties to update: %s" (String.concat ", " (List.map (fun (k, v) -> k ^ "=" ^ v) props_to_update)); + if props_to_update <> [] then + let set_prop (prop, value) = + try + debug "Setting %s=%s on bond %s" prop value master; + Sysfs.write_one_line (Sysfs.getpath master ("bonding/" ^ prop)) value + with _ -> + error "Failed to set property \"%s\" on bond %s" prop master + in + Ip.with_links_down [master] (fun () -> + with_slaves_removed master (fun () -> + List.iter set_prop props_to_update + ) + ) + end else + error "Bond %s does not exist; cannot set properties" master end module Dhclient = struct - let pid_file ?(ipv6=false) interface = - let ipv6' = if ipv6 then "6" else "" in - Printf.sprintf "/var/run/dhclient%s-%s.pid" ipv6' interface - - let lease_file ?(ipv6=false) interface = - let ipv6' = if ipv6 then "6" else "" in - Filename.concat "/var/lib/xcp" (Printf.sprintf "dhclient%s-%s.leases" ipv6' interface) - - let conf_file ?(ipv6=false) interface = - let ipv6' = if ipv6 then "6" else "" in - Filename.concat "/var/lib/xcp" (Printf.sprintf "dhclient%s-%s.conf" ipv6' interface) - - let generate_conf ?(ipv6=false) interface options = - let minimal = ["subnet-mask"; "broadcast-address"; "time-offset"; "host-name"; "nis-domain"; - "nis-servers"; "ntp-servers"; "interface-mtu"] in - let set_gateway = - if List.mem (`gateway interface) options - then (debug "%s is the default gateway interface" interface; ["routers"]) - else (debug "%s is NOT the default gateway interface" interface; []) - in - let set_dns = if List.mem `set_dns options then ["domain-name"; "domain-name-servers"] else [] in - let request = minimal @ set_gateway @ set_dns in - Printf.sprintf "interface \"%s\" {\n request %s;\n}\n" interface (String.concat ", " request) - - let read_conf_file ?(ipv6=false) interface = - let file = conf_file ~ipv6 interface in - try Some (Xapi_stdext_unix.Unixext.string_of_file file) with _ -> None - - let write_conf_file ?(ipv6=false) interface options = - let conf = generate_conf ~ipv6 interface options in - Xapi_stdext_unix.Unixext.write_string_to_file (conf_file ~ipv6 interface) conf - - let start ?(ipv6=false) interface options = - (* If we have a gateway interface, pass it to dhclient-script via -e *) - (* This prevents the default route being set erroneously on CentOS *) - (* Normally this wouldn't happen as we're not requesting routers, *) - (* but some buggy DHCP servers ignore this *) - (* See CA-137892 *) - let gw_opt = List.fold_left - (fun l x -> - match x with - | `gateway y -> ["-e"; "GATEWAYDEV="^y] - | _ -> l) [] options in - write_conf_file ~ipv6 interface options; - let ipv6' = if ipv6 then ["-6"] else [] in - call_script ~log_successful_output:true ~timeout:None dhclient (ipv6' @ gw_opt @ ["-q"; - "-pf"; pid_file ~ipv6 interface; - "-lf"; lease_file ~ipv6 interface; - "-cf"; conf_file ~ipv6 interface; - interface]) - - let stop ?(ipv6=false) interface = - try - ignore (call_script ~log_successful_output:true dhclient ["-r"; - "-pf"; pid_file ~ipv6 interface; - interface]); - Unix.unlink (pid_file ~ipv6 interface) - with _ -> () - - let is_running ?(ipv6=false) interface = - try - Unix.access (pid_file ~ipv6 interface) [Unix.F_OK]; - true - with Unix.Unix_error _ -> - false - - let ensure_running ?(ipv6=false) interface options = - if not(is_running ~ipv6 interface) then - (* dhclient is not running, so we need to start it. *) - ignore (start ~ipv6 interface options) - else begin - (* dhclient is running - if the config has changed, update the config file and restart. *) - let current_conf = read_conf_file ~ipv6 interface in - let new_conf = generate_conf ~ipv6 interface options in - if current_conf <> (Some new_conf) then begin - ignore (stop ~ipv6 interface); - ignore (start ~ipv6 interface options) - end - end + let pid_file ?(ipv6=false) interface = + let ipv6' = if ipv6 then "6" else "" in + Printf.sprintf "/var/run/dhclient%s-%s.pid" ipv6' interface + + let lease_file ?(ipv6=false) interface = + let ipv6' = if ipv6 then "6" else "" in + Filename.concat "/var/lib/xcp" (Printf.sprintf "dhclient%s-%s.leases" ipv6' interface) + + let conf_file ?(ipv6=false) interface = + let ipv6' = if ipv6 then "6" else "" in + Filename.concat "/var/lib/xcp" (Printf.sprintf "dhclient%s-%s.conf" ipv6' interface) + + let generate_conf ?(ipv6=false) interface options = + let minimal = ["subnet-mask"; "broadcast-address"; "time-offset"; "host-name"; "nis-domain"; + "nis-servers"; "ntp-servers"; "interface-mtu"] in + let set_gateway = + if List.mem (`gateway interface) options + then (debug "%s is the default gateway interface" interface; ["routers"]) + else (debug "%s is NOT the default gateway interface" interface; []) + in + let set_dns = if List.mem `set_dns options then ["domain-name"; "domain-name-servers"] else [] in + let request = minimal @ set_gateway @ set_dns in + Printf.sprintf "interface \"%s\" {\n request %s;\n}\n" interface (String.concat ", " request) + + let read_conf_file ?(ipv6=false) interface = + let file = conf_file ~ipv6 interface in + try Some (Xapi_stdext_unix.Unixext.string_of_file file) with _ -> None + + let write_conf_file ?(ipv6=false) interface options = + let conf = generate_conf ~ipv6 interface options in + Xapi_stdext_unix.Unixext.write_string_to_file (conf_file ~ipv6 interface) conf + + let start ?(ipv6=false) interface options = + (* If we have a gateway interface, pass it to dhclient-script via -e *) + (* This prevents the default route being set erroneously on CentOS *) + (* Normally this wouldn't happen as we're not requesting routers, *) + (* but some buggy DHCP servers ignore this *) + (* See CA-137892 *) + let gw_opt = List.fold_left + (fun l x -> + match x with + | `gateway y -> ["-e"; "GATEWAYDEV="^y] + | _ -> l) [] options in + write_conf_file ~ipv6 interface options; + let ipv6' = if ipv6 then ["-6"] else [] in + call_script ~log_successful_output:true ~timeout:None dhclient (ipv6' @ gw_opt @ ["-q"; + "-pf"; pid_file ~ipv6 interface; + "-lf"; lease_file ~ipv6 interface; + "-cf"; conf_file ~ipv6 interface; + interface]) + + let stop ?(ipv6=false) interface = + try + ignore (call_script ~log_successful_output:true dhclient ["-r"; + "-pf"; pid_file ~ipv6 interface; + interface]); + Unix.unlink (pid_file ~ipv6 interface) + with _ -> () + + let is_running ?(ipv6=false) interface = + try + Unix.access (pid_file ~ipv6 interface) [Unix.F_OK]; + true + with Unix.Unix_error _ -> + false + + let ensure_running ?(ipv6=false) interface options = + if not(is_running ~ipv6 interface) then + (* dhclient is not running, so we need to start it. *) + ignore (start ~ipv6 interface options) + else begin + (* dhclient is running - if the config has changed, update the config file and restart. *) + let current_conf = read_conf_file ~ipv6 interface in + let new_conf = generate_conf ~ipv6 interface options in + if current_conf <> (Some new_conf) then begin + ignore (stop ~ipv6 interface); + ignore (start ~ipv6 interface options) + end + end end module Fcoe = struct - let call ?(log=false) args = - call_script ~log_successful_output:log ~timeout:(Some 10.0) !fcoedriver args - - let get_capabilities name = - try - let output = call ["--xapi"; name; "capable"] in - if Astring.String.is_infix ~affix:"True" output then ["fcoe"] else [] - with _ -> - debug "Failed to get fcoe support status on device %s" name; - [] + let call ?(log=false) args = + call_script ~log_successful_output:log ~timeout:(Some 10.0) !fcoedriver args + + let get_capabilities name = + try + let output = call ["--xapi"; name; "capable"] in + if Astring.String.is_infix ~affix:"True" output then ["fcoe"] else [] + with _ -> + debug "Failed to get fcoe support status on device %s" name; + [] end module Sysctl = struct - let write value variable = - ignore (call_script ~log_successful_output:true sysctl ["-q"; "-w"; variable ^ "=" ^ value]) - - let set_ipv6_autoconf interface value = - try - let variables = [ - "net.ipv6.conf." ^ interface ^ ".autoconf"; - "net.ipv6.conf." ^ interface ^ ".accept_ra" - ] in - let value' = if value then "1" else "0" in - List.iter (write value') variables - with - | e when value = true -> raise e - | _ -> () + let write value variable = + ignore (call_script ~log_successful_output:true sysctl ["-q"; "-w"; variable ^ "=" ^ value]) + + let set_ipv6_autoconf interface value = + try + let variables = [ + "net.ipv6.conf." ^ interface ^ ".autoconf"; + "net.ipv6.conf." ^ interface ^ ".accept_ra" + ] in + let value' = if value then "1" else "0" in + List.iter (write value') variables + with + | e when value = true -> raise e + | _ -> () end module Proc = struct - let get_bond_slave_info name key = - try - let raw = Xapi_stdext_unix.Unixext.string_of_file (bonding_dir ^ name) in - let lines = Astring.String.cuts ~empty:false ~sep:"\n" raw in - let check_lines lines = - let rec loop current acc = function - | [] -> acc - | line :: tail -> - try - Scanf.sscanf line "%s@: %s@\n" (fun k v -> - if k = "Slave Interface" then begin - let interface = Some (String.trim v) in - loop interface acc tail - end else if k = key then - match current with - | Some interface -> loop current ((interface, String.trim v) :: acc) tail - | None -> loop current acc tail - else - loop current acc tail - ) - with _ -> - loop current acc tail - in - loop None [] lines - in - check_lines lines - with e -> - error "Error: could not read %s." (bonding_dir ^ name); - [] - - let get_bond_slave_mac name slave = - let macs = get_bond_slave_info name "Permanent HW addr" in - if List.mem_assoc slave macs then - List.assoc slave macs - else - raise Not_found - -let get_vlans () = - try - Xapi_stdext_unix.Unixext.file_lines_fold (fun vlans line -> - try - let x = Scanf.sscanf line "%s | %d | %s" (fun device vlan parent -> device, vlan, parent) in - x :: vlans - with _ -> - vlans - ) [] "/proc/net/vlan/config" - with e -> - error "Error: could not read /proc/net/vlan/config"; - [] - - let get_bond_links_up name = - let statusses = get_bond_slave_info name "MII Status" in - List.fold_left (fun x (_, y) -> x + (if y = "up" then 1 else 0)) 0 statusses + let get_bond_slave_info name key = + try + let raw = Xapi_stdext_unix.Unixext.string_of_file (bonding_dir ^ name) in + let lines = Astring.String.cuts ~empty:false ~sep:"\n" raw in + let check_lines lines = + let rec loop current acc = function + | [] -> acc + | line :: tail -> + try + Scanf.sscanf line "%s@: %s@\n" (fun k v -> + if k = "Slave Interface" then begin + let interface = Some (String.trim v) in + loop interface acc tail + end else if k = key then + match current with + | Some interface -> loop current ((interface, String.trim v) :: acc) tail + | None -> loop current acc tail + else + loop current acc tail + ) + with _ -> + loop current acc tail + in + loop None [] lines + in + check_lines lines + with e -> + error "Error: could not read %s." (bonding_dir ^ name); + [] + + let get_bond_slave_mac name slave = + let macs = get_bond_slave_info name "Permanent HW addr" in + if List.mem_assoc slave macs then + List.assoc slave macs + else + raise Not_found + + let get_vlans () = + try + Xapi_stdext_unix.Unixext.file_lines_fold (fun vlans line -> + try + let x = Scanf.sscanf line "%s | %d | %s" (fun device vlan parent -> device, vlan, parent) in + x :: vlans + with _ -> + vlans + ) [] "/proc/net/vlan/config" + with e -> + error "Error: could not read /proc/net/vlan/config"; + [] + + let get_bond_links_up name = + let statusses = get_bond_slave_info name "MII Status" in + List.fold_left (fun x (_, y) -> x + (if y = "up" then 1 else 0)) 0 statusses end module Ovs = struct - module Cli : sig - val vsctl : ?log:bool -> string list -> string - val ofctl : ?log:bool -> string list -> string - val appctl : ?log:bool -> string list -> string - end = struct - open Xapi_stdext_threads - let s = Semaphore.create 5 - let vsctl ?(log=false) args = - Semaphore.execute s (fun () -> - call_script ~log_successful_output:log ovs_vsctl ("--timeout=20" :: args) - ) - let ofctl ?(log=false) args = - call_script ~log_successful_output:log ovs_ofctl args - let appctl ?(log=false) args = - call_script ~log_successful_output:log ovs_appctl args - end - - module type Cli_S = module type of Cli - - module Make(Cli : Cli_S) = struct - include Cli - - let port_to_interfaces name = - try - let raw = vsctl ["get"; "port"; name; "interfaces"] in - let raw = String.trim raw in - if raw <> "[]" then - let raw_list = (Astring.String.cuts ~empty:false ~sep:"," (String.sub raw 1 (String.length raw - 2))) in - let uuids = List.map (String.trim) raw_list in - List.map (fun uuid -> - let raw = String.trim (vsctl ["get"; "interface"; uuid; "name"]) in - String.sub raw 1 (String.length raw - 2)) uuids - else - [] - with _ -> [] - - let bridge_to_ports name = - try - let ports = String.trim (vsctl ["list-ports"; name]) in - let ports' = - if ports <> "" then - Astring.String.cuts ~empty:false ~sep:"\n" ports - else - [] - in - List.map (fun port -> port, port_to_interfaces port) ports' - with _ -> [] - - let bridge_to_interfaces name = - try - let ifaces = String.trim (vsctl ["list-ifaces"; name]) in - if ifaces <> "" then - Astring.String.cuts ~empty:false ~sep:"\n" ifaces - else - [] - with _ -> [] - - let bridge_to_vlan name = - try - let parent = vsctl ["br-to-parent"; name] |> String.trim in - let vlan = vsctl ["br-to-vlan"; name] |> String.trim |> int_of_string in - Some (parent, vlan) - with e -> - debug "bridge_to_vlan: %s" (Printexc.to_string e); - None - - let get_real_bridge name = - match bridge_to_vlan name with - | Some (parent, vlan) -> parent - | None -> name - - let get_bond_link_status name = - try - let raw = appctl ["bond/show"; name] in - let lines = Astring.String.cuts ~empty:false ~sep:"\n" raw in - List.fold_left (fun (slaves, active_slave) line -> - let slaves = - try - Scanf.sscanf line "slave %s@: %s" (fun slave state -> - (slave, state = "enabled") :: slaves - ) - with _ -> slaves - in - let active_slave = - try - Scanf.sscanf line "active slave %s@(%s@)" (fun _ slave -> Some slave) - with _ -> active_slave - in - slaves, active_slave - ) ([], None) lines - with _ -> [], None - - let get_bond_links_up name = - let slaves, _ = get_bond_link_status name in - let links_up = List.filter snd slaves in - List.length (links_up) - - let get_bond_mode name = - try - let output = String.trim (vsctl ["get"; "port"; name; "bond_mode"]) in - if output <> "[]" then Some output else None - with _ -> - None - - let set_max_idle t = - try - ignore (vsctl ["set"; "Open_vSwitch"; "."; Printf.sprintf "other_config:max-idle=%d" t]) - with _ -> - warn "Failed to set max-idle=%d on OVS" t - - let handle_vlan_bug_workaround override bridge = - (* This is a list of drivers that do support VLAN tx or rx acceleration, but - * to which the VLAN bug workaround should not be applied. This could be - * because these are known-good drivers (that is, they do not have any of - * the bugs that the workaround avoids) or because the VLAN bug workaround - * will not work for them and may cause other problems. - * - * This is a very short list because few drivers have been tested. *) - let no_vlan_workaround_drivers = ["bonding"] in - let phy_interfaces = - try - let interfaces = bridge_to_interfaces bridge in - List.filter Sysfs.is_physical interfaces - with _ -> [] - in - List.iter (fun interface -> - let do_workaround = - match override with - | Some value -> value - | None -> - match Sysfs.get_driver_name interface with - | None -> - Sysfs.has_vlan_accel interface - | Some driver -> - if List.mem driver no_vlan_workaround_drivers then - false - else - Sysfs.has_vlan_accel interface - in - let setting = if do_workaround then "on" else "off" in - (try - ignore (call_script ~log_successful_output:true ovs_vlan_bug_workaround [interface; setting]); - with _ -> ()); - ) phy_interfaces - - let get_vlans name = - try - let vlans_with_uuid = - let raw = vsctl ["--bare"; "-f"; "table"; "--"; "--columns=name,_uuid"; "find"; "port"; "fake_bridge=true"] in - if raw <> "" then - let lines = Astring.String.cuts ~empty:false ~sep:"\n" (String.trim raw) in - List.map (fun line -> Scanf.sscanf line "%s %s" (fun a b-> a, b)) lines - else - [] - in - let bridge_ports = - let raw = vsctl ["get"; "bridge"; name; "ports"] in - let raw = String.trim raw in - if raw <> "[]" then - let raw_list = (Astring.String.cuts ~empty:false ~sep:"," (String.sub raw 1 (String.length raw - 2))) in - List.map String.trim raw_list - else - [] - in - let vlans_on_bridge = List.filter (fun (_, br) -> List.mem br bridge_ports) vlans_with_uuid in - List.map (fun (n, _) -> n) vlans_on_bridge - with _ -> [] - - let get_bridge_vlan_vifs ~name = - try - let vlan_fake_bridges = get_vlans name in - List.fold_left(fun vifs br -> - let vifs' = bridge_to_interfaces br in - vifs' @ vifs) [] vlan_fake_bridges - with _ -> [] - - let get_mcast_snooping_enable ~name = - try - vsctl ~log:true ["--"; "get"; "bridge"; name; "mcast_snooping_enable"] - |> String.trim - |> bool_of_string - with _ -> false - - let inject_igmp_query ~name = - try - let vvifs = get_bridge_vlan_vifs name in - let bvifs = bridge_to_interfaces name in - let bvifs' = List.filter (fun vif -> Astring.String.is_prefix ~affix:"vif" vif) bvifs in - (* The vifs may be large. However considering current XS limit of 1000VM*7NIC/VM + 800VLANs, the buffer of CLI should be sufficient for lots of vifxxxx.xx *) - fork_script !inject_igmp_query_script (["--no-check-snooping-toggle"; "--max-resp-time"; !igmp_query_maxresp_time] @ bvifs' @ vvifs) - with _ -> () - - let create_bridge ?mac ?external_id ?disable_in_band ?igmp_snooping ~fail_mode vlan vlan_bug_workaround name = - let vlan_arg = match vlan with - | None -> [] - | Some (parent, tag) -> - handle_vlan_bug_workaround vlan_bug_workaround parent; - [parent; string_of_int tag] - in - let mac_arg = match mac with - | None -> [] - | Some mac -> - if vlan = None then - ["--"; "set"; "bridge"; name; Printf.sprintf "other-config:hwaddr=\"%s\"" (String.escaped mac)] - else - ["--"; "set"; "interface"; name; Printf.sprintf "MAC=\"%s\"" (String.escaped mac)] - in - let fail_mode_arg = - if vlan = None then ["--"; "set"; "bridge"; name; "fail_mode=" ^ fail_mode] else [] in - let external_id_arg = match external_id with - | None -> [] - | Some (key, value) -> - match vlan with - | None -> ["--"; "br-set-external-id"; name; key; value] - | Some (parent, _) -> ["--"; "br-set-external-id"; parent; key; value] - in - let disable_in_band_arg = - if vlan = None then - match disable_in_band with - | None -> [] - | Some None -> ["--"; "remove"; "bridge"; name; "other_config"; "disable-in-band"] - | Some (Some dib) -> ["--"; "set"; "bridge"; name; "other_config:disable-in-band=" ^ dib] - else - [] - in - let vif_arg = - let existing_vifs = List.filter (fun iface -> not (Sysfs.is_physical iface)) (bridge_to_interfaces name) in - List.flatten (List.map (fun vif -> ["--"; "--may-exist"; "add-port"; name; vif]) existing_vifs) - in - let del_old_arg = - if vlan <> None then - (* This is to handle the case that a "real" bridge (not a "fake" VLAN bridge) already exists *) - ["--"; "--if-exists"; "del-br"; name] - else - [] - in - let set_mac_table_size = - if vlan = None then - ["--"; "set"; "bridge"; name; "other_config:mac-table-size=" ^ (string_of_int !mac_table_size)] - else - [] - in - let set_igmp_snooping = match igmp_snooping, vlan with - | Some x, None -> ["--"; "set"; "bridge"; name; "mcast_snooping_enable=" ^ (string_of_bool x)] - | _ -> [] - in - let set_ipv6_igmp_snooping = match igmp_snooping, vlan with - | Some _, None -> ["--"; "set"; "bridge"; name; "other_config:enable-ipv6-mcast-snooping=" ^ (string_of_bool !enable_ipv6_mcast_snooping)] - | _ -> [] - in - let disable_flood_unregistered = match igmp_snooping, vlan with - | Some _, None -> - ["--"; "set"; "bridge"; name; "other_config:mcast-snooping-disable-flood-unregistered=" ^ (string_of_bool !mcast_snooping_disable_flood_unregistered)] - | _ -> [] - in - vsctl ~log:true (del_old_arg @ ["--"; "--may-exist"; "add-br"; name] @ - vlan_arg @ mac_arg @ fail_mode_arg @ disable_in_band_arg @ external_id_arg @ vif_arg @ set_mac_table_size @ set_igmp_snooping @ set_ipv6_igmp_snooping @ disable_flood_unregistered) - - let destroy_bridge name = - vsctl ~log:true ["--"; "--if-exists"; "del-br"; name] - - let list_bridges () = - let bridges = String.trim (vsctl ["list-br"]) in - if bridges <> "" then - Astring.String.cuts ~empty:false ~sep:"\n" bridges - else - [] - - let create_port ?(internal=false) name bridge = - let type_args = - if internal then ["--"; "set"; "interface"; name; "type=internal"] else [] in - vsctl ~log:true (["--"; "--may-exist"; "add-port"; bridge; name] @ type_args) - - let destroy_port name = - vsctl ~log:true ["--"; "--with-iface"; "--if-exists"; "del-port"; name] - - let port_to_bridge name = - vsctl ~log:true ["port-to-br"; name] - - let make_bond_properties name properties = - let known_props = ["mode"; "hashing-algorithm"; "updelay"; "downdelay"; - "miimon"; "use_carrier"; "rebalance-interval"; - "lacp-time"; "lacp-aggregation-key"; "lacp-fallback-ab"] in - let mode_args = - let mode = if List.mem_assoc "mode" properties - then List.assoc "mode" properties else "balance-slb" in - let halgo = if List.mem_assoc "hashing-algorithm" properties - then List.assoc "hashing-algorithm" properties else "" in - if mode = "lacp" then "lacp=active" :: - (if halgo = "src_mac" then ["bond_mode=balance-slb"] - else if halgo = "tcpudp_ports" then ["bond_mode=balance-tcp"] - else begin - debug "bond %s has invalid bond-hashing-algorithm '%s'; defaulting to balance-tcp" - name halgo; - ["bond_mode=balance-tcp"] - end) - else - ["lacp=off"; "bond_mode=" ^ mode] - in - (* "legacy" converter for bond properties *) - let get_prop_legacy (prop, ovs_key) = - if List.mem_assoc prop properties then - let value = List.assoc prop properties in - let value' = try int_of_string value with _ -> -1 in - if value' < 0 then begin - debug "bond %s has invalid %s '%s'\n" name prop value; - [] - end else if prop = "use_carrier" then - [ovs_key ^ "=" ^ (if value' > 0 then "carrier" else "miimon")] - else - [ovs_key ^ "=" ^ (string_of_int value')] - else - [] - and get_prop (prop, ovs_key) = - if List.mem_assoc prop properties - then let value = List.assoc prop properties in - [ovs_key ^ "=\"" ^ value ^ "\""] - else [] - in - (* Don't add new properties here, these use the legacy converter *) - let extra_args_legacy = List.flatten (List.map get_prop_legacy - ["updelay", "bond_updelay"; "downdelay", "bond_downdelay"; - "miimon", "other-config:bond-miimon-interval"; - "use_carrier", "other-config:bond-detect-mode"; - "rebalance-interval", "other-config:bond-rebalance-interval";]) - and extra_args = List.flatten (List.map get_prop - ["lacp-time", "other-config:lacp-time"; - "lacp-fallback-ab", "other-config:lacp-fallback-ab";]) - and per_iface_args = List.flatten (List.map get_prop - ["lacp-aggregation-key", "other-config:lacp-aggregation-key"; - "lacp-actor-key", "other-config:lacp-actor-key";]) - and other_args = Xapi_stdext_std.Listext.List.filter_map (fun (k, v) -> - if List.mem k known_props then None - else Some (Printf.sprintf "other-config:\"%s\"=\"%s\"" - (String.escaped ("bond-" ^ k)) (String.escaped v)) - ) properties in - (mode_args @ extra_args_legacy @ extra_args @ other_args, per_iface_args) - - let create_bond ?mac name interfaces bridge properties = - let args, per_iface_args = make_bond_properties name properties in - let mac_args = match mac with - | None -> [] - | Some mac -> ["--"; "set"; "port"; name; "MAC=\"" ^ (String.escaped mac) ^ "\""] - in - let per_iface_args = - if per_iface_args = [] - then [] - else List.flatten - (List.map - (fun iface -> - ["--"; "set"; "interface"; iface ] @ per_iface_args) - interfaces) - in - vsctl ~log:true (["--"; "--may-exist"; "add-bond"; bridge; name] @ interfaces @ - mac_args @ args @ per_iface_args) - - let get_fail_mode bridge = - vsctl ["get-fail-mode"; bridge] - - let add_default_flows bridge mac interfaces = - let ports = List.map (fun interface -> vsctl ["get"; "interface"; interface; "ofport"]) interfaces in - let flows = match ports with - | [port] -> - [Printf.sprintf "idle_timeout=0,priority=0,in_port=%s,arp,nw_proto=1,actions=local" port; - Printf.sprintf "idle_timeout=0,priority=0,in_port=local,arp,dl_src=%s,actions=%s" mac port; - Printf.sprintf "idle_timeout=0,priority=0,in_port=%s,dl_dst=%s,actions=local" port mac; - Printf.sprintf "idle_timeout=0,priority=0,in_port=local,dl_src=%s,actions=%s" mac port] - | ports -> - List.flatten (List.map (fun port -> - [Printf.sprintf "idle_timeout=0,priority=0,in_port=local,arp,dl_src=%s,actions=NORMAL" mac; - Printf.sprintf "idle_timeout=0,priority=0,in_port=local,dl_src=%s,actions=NORMAL" mac; - Printf.sprintf "idle_timeout=0,priority=0,in_port=%s,arp,nw_proto=1,actions=local" port; - Printf.sprintf "idle_timeout=0,priority=0,in_port=%s,dl_dst=%s,actions=local" port mac] - ) ports) - in - List.iter (fun flow -> ignore (ofctl ~log:true ["add-flow"; bridge; flow])) flows - - let mod_port bridge port action = - ofctl ~log:true ["mod-port"; bridge; port; action] |> ignore - - let set_mtu interface mtu = - vsctl ~log:true ["set"; "interface"; interface; Printf.sprintf "mtu_request=%d" mtu] - - end - include Make(Cli) + module Cli : sig + val vsctl : ?log:bool -> string list -> string + val ofctl : ?log:bool -> string list -> string + val appctl : ?log:bool -> string list -> string + end = struct + open Xapi_stdext_threads + let s = Semaphore.create 5 + let vsctl ?(log=false) args = + Semaphore.execute s (fun () -> + call_script ~log_successful_output:log ovs_vsctl ("--timeout=20" :: args) + ) + let ofctl ?(log=false) args = + call_script ~log_successful_output:log ovs_ofctl args + let appctl ?(log=false) args = + call_script ~log_successful_output:log ovs_appctl args + end + + module type Cli_S = module type of Cli + + module Make(Cli : Cli_S) = struct + include Cli + + let port_to_interfaces name = + try + let raw = vsctl ["get"; "port"; name; "interfaces"] in + let raw = String.trim raw in + if raw <> "[]" then + let raw_list = (Astring.String.cuts ~empty:false ~sep:"," (String.sub raw 1 (String.length raw - 2))) in + let uuids = List.map (String.trim) raw_list in + List.map (fun uuid -> + let raw = String.trim (vsctl ["get"; "interface"; uuid; "name"]) in + String.sub raw 1 (String.length raw - 2)) uuids + else + [] + with _ -> [] + + let bridge_to_ports name = + try + let ports = String.trim (vsctl ["list-ports"; name]) in + let ports' = + if ports <> "" then + Astring.String.cuts ~empty:false ~sep:"\n" ports + else + [] + in + List.map (fun port -> port, port_to_interfaces port) ports' + with _ -> [] + + let bridge_to_interfaces name = + try + let ifaces = String.trim (vsctl ["list-ifaces"; name]) in + if ifaces <> "" then + Astring.String.cuts ~empty:false ~sep:"\n" ifaces + else + [] + with _ -> [] + + let bridge_to_vlan name = + try + let parent = vsctl ["br-to-parent"; name] |> String.trim in + let vlan = vsctl ["br-to-vlan"; name] |> String.trim |> int_of_string in + Some (parent, vlan) + with e -> + debug "bridge_to_vlan: %s" (Printexc.to_string e); + None + + let get_real_bridge name = + match bridge_to_vlan name with + | Some (parent, vlan) -> parent + | None -> name + + let get_bond_link_status name = + try + let raw = appctl ["bond/show"; name] in + let lines = Astring.String.cuts ~empty:false ~sep:"\n" raw in + List.fold_left (fun (slaves, active_slave) line -> + let slaves = + try + Scanf.sscanf line "slave %s@: %s" (fun slave state -> + (slave, state = "enabled") :: slaves + ) + with _ -> slaves + in + let active_slave = + try + Scanf.sscanf line "active slave %s@(%s@)" (fun _ slave -> Some slave) + with _ -> active_slave + in + slaves, active_slave + ) ([], None) lines + with _ -> [], None + + let get_bond_links_up name = + let slaves, _ = get_bond_link_status name in + let links_up = List.filter snd slaves in + List.length (links_up) + + let get_bond_mode name = + try + let output = String.trim (vsctl ["get"; "port"; name; "bond_mode"]) in + if output <> "[]" then Some output else None + with _ -> + None + + let set_max_idle t = + try + ignore (vsctl ["set"; "Open_vSwitch"; "."; Printf.sprintf "other_config:max-idle=%d" t]) + with _ -> + warn "Failed to set max-idle=%d on OVS" t + + let handle_vlan_bug_workaround override bridge = + (* This is a list of drivers that do support VLAN tx or rx acceleration, but + * to which the VLAN bug workaround should not be applied. This could be + * because these are known-good drivers (that is, they do not have any of + * the bugs that the workaround avoids) or because the VLAN bug workaround + * will not work for them and may cause other problems. + * + * This is a very short list because few drivers have been tested. *) + let no_vlan_workaround_drivers = ["bonding"] in + let phy_interfaces = + try + let interfaces = bridge_to_interfaces bridge in + List.filter Sysfs.is_physical interfaces + with _ -> [] + in + List.iter (fun interface -> + let do_workaround = + match override with + | Some value -> value + | None -> + match Sysfs.get_driver_name interface with + | None -> + Sysfs.has_vlan_accel interface + | Some driver -> + if List.mem driver no_vlan_workaround_drivers then + false + else + Sysfs.has_vlan_accel interface + in + let setting = if do_workaround then "on" else "off" in + (try + ignore (call_script ~log_successful_output:true ovs_vlan_bug_workaround [interface; setting]); + with _ -> ()); + ) phy_interfaces + + let get_vlans name = + try + let vlans_with_uuid = + let raw = vsctl ["--bare"; "-f"; "table"; "--"; "--columns=name,_uuid"; "find"; "port"; "fake_bridge=true"] in + if raw <> "" then + let lines = Astring.String.cuts ~empty:false ~sep:"\n" (String.trim raw) in + List.map (fun line -> Scanf.sscanf line "%s %s" (fun a b-> a, b)) lines + else + [] + in + let bridge_ports = + let raw = vsctl ["get"; "bridge"; name; "ports"] in + let raw = String.trim raw in + if raw <> "[]" then + let raw_list = (Astring.String.cuts ~empty:false ~sep:"," (String.sub raw 1 (String.length raw - 2))) in + List.map String.trim raw_list + else + [] + in + let vlans_on_bridge = List.filter (fun (_, br) -> List.mem br bridge_ports) vlans_with_uuid in + List.map (fun (n, _) -> n) vlans_on_bridge + with _ -> [] + + let get_bridge_vlan_vifs ~name = + try + let vlan_fake_bridges = get_vlans name in + List.fold_left(fun vifs br -> + let vifs' = bridge_to_interfaces br in + vifs' @ vifs) [] vlan_fake_bridges + with _ -> [] + + let get_mcast_snooping_enable ~name = + try + vsctl ~log:true ["--"; "get"; "bridge"; name; "mcast_snooping_enable"] + |> String.trim + |> bool_of_string + with _ -> false + + let inject_igmp_query ~name = + try + let vvifs = get_bridge_vlan_vifs name in + let bvifs = bridge_to_interfaces name in + let bvifs' = List.filter (fun vif -> Astring.String.is_prefix ~affix:"vif" vif) bvifs in + (* The vifs may be large. However considering current XS limit of 1000VM*7NIC/VM + 800VLANs, the buffer of CLI should be sufficient for lots of vifxxxx.xx *) + fork_script !inject_igmp_query_script (["--no-check-snooping-toggle"; "--max-resp-time"; !igmp_query_maxresp_time] @ bvifs' @ vvifs) + with _ -> () + + let create_bridge ?mac ?external_id ?disable_in_band ?igmp_snooping ~fail_mode vlan vlan_bug_workaround name = + let vlan_arg = match vlan with + | None -> [] + | Some (parent, tag) -> + handle_vlan_bug_workaround vlan_bug_workaround parent; + [parent; string_of_int tag] + in + let mac_arg = match mac with + | None -> [] + | Some mac -> + if vlan = None then + ["--"; "set"; "bridge"; name; Printf.sprintf "other-config:hwaddr=\"%s\"" (String.escaped mac)] + else + ["--"; "set"; "interface"; name; Printf.sprintf "MAC=\"%s\"" (String.escaped mac)] + in + let fail_mode_arg = + if vlan = None then ["--"; "set"; "bridge"; name; "fail_mode=" ^ fail_mode] else [] in + let external_id_arg = match external_id with + | None -> [] + | Some (key, value) -> + match vlan with + | None -> ["--"; "br-set-external-id"; name; key; value] + | Some (parent, _) -> ["--"; "br-set-external-id"; parent; key; value] + in + let disable_in_band_arg = + if vlan = None then + match disable_in_band with + | None -> [] + | Some None -> ["--"; "remove"; "bridge"; name; "other_config"; "disable-in-band"] + | Some (Some dib) -> ["--"; "set"; "bridge"; name; "other_config:disable-in-band=" ^ dib] + else + [] + in + let vif_arg = + let existing_vifs = List.filter (fun iface -> not (Sysfs.is_physical iface)) (bridge_to_interfaces name) in + List.flatten (List.map (fun vif -> ["--"; "--may-exist"; "add-port"; name; vif]) existing_vifs) + in + let del_old_arg = + if vlan <> None then + (* This is to handle the case that a "real" bridge (not a "fake" VLAN bridge) already exists *) + ["--"; "--if-exists"; "del-br"; name] + else + [] + in + let set_mac_table_size = + if vlan = None then + ["--"; "set"; "bridge"; name; "other_config:mac-table-size=" ^ (string_of_int !mac_table_size)] + else + [] + in + let set_igmp_snooping = match igmp_snooping, vlan with + | Some x, None -> ["--"; "set"; "bridge"; name; "mcast_snooping_enable=" ^ (string_of_bool x)] + | _ -> [] + in + let set_ipv6_igmp_snooping = match igmp_snooping, vlan with + | Some _, None -> ["--"; "set"; "bridge"; name; "other_config:enable-ipv6-mcast-snooping=" ^ (string_of_bool !enable_ipv6_mcast_snooping)] + | _ -> [] + in + let disable_flood_unregistered = match igmp_snooping, vlan with + | Some _, None -> + ["--"; "set"; "bridge"; name; "other_config:mcast-snooping-disable-flood-unregistered=" ^ (string_of_bool !mcast_snooping_disable_flood_unregistered)] + | _ -> [] + in + vsctl ~log:true (del_old_arg @ ["--"; "--may-exist"; "add-br"; name] @ + vlan_arg @ mac_arg @ fail_mode_arg @ disable_in_band_arg @ external_id_arg @ vif_arg @ set_mac_table_size @ set_igmp_snooping @ set_ipv6_igmp_snooping @ disable_flood_unregistered) + + let destroy_bridge name = + vsctl ~log:true ["--"; "--if-exists"; "del-br"; name] + + let list_bridges () = + let bridges = String.trim (vsctl ["list-br"]) in + if bridges <> "" then + Astring.String.cuts ~empty:false ~sep:"\n" bridges + else + [] + + let create_port ?(internal=false) name bridge = + let type_args = + if internal then ["--"; "set"; "interface"; name; "type=internal"] else [] in + vsctl ~log:true (["--"; "--may-exist"; "add-port"; bridge; name] @ type_args) + + let destroy_port name = + vsctl ~log:true ["--"; "--with-iface"; "--if-exists"; "del-port"; name] + + let port_to_bridge name = + vsctl ~log:true ["port-to-br"; name] + + let make_bond_properties name properties = + let known_props = ["mode"; "hashing-algorithm"; "updelay"; "downdelay"; + "miimon"; "use_carrier"; "rebalance-interval"; + "lacp-time"; "lacp-aggregation-key"; "lacp-fallback-ab"] in + let mode_args = + let mode = if List.mem_assoc "mode" properties + then List.assoc "mode" properties else "balance-slb" in + let halgo = if List.mem_assoc "hashing-algorithm" properties + then List.assoc "hashing-algorithm" properties else "" in + if mode = "lacp" then "lacp=active" :: + (if halgo = "src_mac" then ["bond_mode=balance-slb"] + else if halgo = "tcpudp_ports" then ["bond_mode=balance-tcp"] + else begin + debug "bond %s has invalid bond-hashing-algorithm '%s'; defaulting to balance-tcp" + name halgo; + ["bond_mode=balance-tcp"] + end) + else + ["lacp=off"; "bond_mode=" ^ mode] + in + (* "legacy" converter for bond properties *) + let get_prop_legacy (prop, ovs_key) = + if List.mem_assoc prop properties then + let value = List.assoc prop properties in + let value' = try int_of_string value with _ -> -1 in + if value' < 0 then begin + debug "bond %s has invalid %s '%s'\n" name prop value; + [] + end else if prop = "use_carrier" then + [ovs_key ^ "=" ^ (if value' > 0 then "carrier" else "miimon")] + else + [ovs_key ^ "=" ^ (string_of_int value')] + else + [] + and get_prop (prop, ovs_key) = + if List.mem_assoc prop properties + then let value = List.assoc prop properties in + [ovs_key ^ "=\"" ^ value ^ "\""] + else [] + in + (* Don't add new properties here, these use the legacy converter *) + let extra_args_legacy = List.flatten (List.map get_prop_legacy + ["updelay", "bond_updelay"; "downdelay", "bond_downdelay"; + "miimon", "other-config:bond-miimon-interval"; + "use_carrier", "other-config:bond-detect-mode"; + "rebalance-interval", "other-config:bond-rebalance-interval";]) + and extra_args = List.flatten (List.map get_prop + ["lacp-time", "other-config:lacp-time"; + "lacp-fallback-ab", "other-config:lacp-fallback-ab";]) + and per_iface_args = List.flatten (List.map get_prop + ["lacp-aggregation-key", "other-config:lacp-aggregation-key"; + "lacp-actor-key", "other-config:lacp-actor-key";]) + and other_args = Xapi_stdext_std.Listext.List.filter_map (fun (k, v) -> + if List.mem k known_props then None + else Some (Printf.sprintf "other-config:\"%s\"=\"%s\"" + (String.escaped ("bond-" ^ k)) (String.escaped v)) + ) properties in + (mode_args @ extra_args_legacy @ extra_args @ other_args, per_iface_args) + + let create_bond ?mac name interfaces bridge properties = + let args, per_iface_args = make_bond_properties name properties in + let mac_args = match mac with + | None -> [] + | Some mac -> ["--"; "set"; "port"; name; "MAC=\"" ^ (String.escaped mac) ^ "\""] + in + let per_iface_args = + if per_iface_args = [] + then [] + else List.flatten + (List.map + (fun iface -> + ["--"; "set"; "interface"; iface ] @ per_iface_args) + interfaces) + in + vsctl ~log:true (["--"; "--may-exist"; "add-bond"; bridge; name] @ interfaces @ + mac_args @ args @ per_iface_args) + + let get_fail_mode bridge = + vsctl ["get-fail-mode"; bridge] + + let add_default_flows bridge mac interfaces = + let ports = List.map (fun interface -> vsctl ["get"; "interface"; interface; "ofport"]) interfaces in + let flows = match ports with + | [port] -> + [Printf.sprintf "idle_timeout=0,priority=0,in_port=%s,arp,nw_proto=1,actions=local" port; + Printf.sprintf "idle_timeout=0,priority=0,in_port=local,arp,dl_src=%s,actions=%s" mac port; + Printf.sprintf "idle_timeout=0,priority=0,in_port=%s,dl_dst=%s,actions=local" port mac; + Printf.sprintf "idle_timeout=0,priority=0,in_port=local,dl_src=%s,actions=%s" mac port] + | ports -> + List.flatten (List.map (fun port -> + [Printf.sprintf "idle_timeout=0,priority=0,in_port=local,arp,dl_src=%s,actions=NORMAL" mac; + Printf.sprintf "idle_timeout=0,priority=0,in_port=local,dl_src=%s,actions=NORMAL" mac; + Printf.sprintf "idle_timeout=0,priority=0,in_port=%s,arp,nw_proto=1,actions=local" port; + Printf.sprintf "idle_timeout=0,priority=0,in_port=%s,dl_dst=%s,actions=local" port mac] + ) ports) + in + List.iter (fun flow -> ignore (ofctl ~log:true ["add-flow"; bridge; flow])) flows + + let mod_port bridge port action = + ofctl ~log:true ["mod-port"; bridge; port; action] |> ignore + + let set_mtu interface mtu = + vsctl ~log:true ["set"; "interface"; interface; Printf.sprintf "mtu_request=%d" mtu] + + end + include Make(Cli) end module Brctl = struct - let call ?(log=false) args = - call_script ~log_successful_output:log !brctl args + let call ?(log=false) args = + call_script ~log_successful_output:log !brctl args - let create_bridge name = - if not (List.mem name (Sysfs.list ())) then - ignore (call ~log:true ["addbr"; name]) + let create_bridge name = + if not (List.mem name (Sysfs.list ())) then + ignore (call ~log:true ["addbr"; name]) - let destroy_bridge name = - if List.mem name (Sysfs.list ()) then - ignore (call ~log:true ["delbr"; name]) + let destroy_bridge name = + if List.mem name (Sysfs.list ()) then + ignore (call ~log:true ["delbr"; name]) - let create_port bridge name = - if not (List.mem name (Sysfs.bridge_to_interfaces bridge)) then - ignore (call ~log:true ["addif"; bridge; name]) + let create_port bridge name = + if not (List.mem name (Sysfs.bridge_to_interfaces bridge)) then + ignore (call ~log:true ["addif"; bridge; name]) - let destroy_port bridge name = - if List.mem name (Sysfs.bridge_to_interfaces bridge) then - ignore (call ~log:true ["delif"; bridge; name]) + let destroy_port bridge name = + if List.mem name (Sysfs.bridge_to_interfaces bridge) then + ignore (call ~log:true ["delif"; bridge; name]) - let set_forwarding_delay bridge time = - ignore (call ~log:true ["setfd"; bridge; string_of_int time]) + let set_forwarding_delay bridge time = + ignore (call ~log:true ["setfd"; bridge; string_of_int time]) end module Ethtool = struct - let call ?(log=false) args = - call_script ~log_successful_output:log !ethtool args + let call ?(log=false) args = + call_script ~log_successful_output:log !ethtool args - let set_options name options = - if options <> [] then - ignore (call ~log:true ("-s" :: name :: (List.concat (List.map (fun (k, v) -> [k; v]) options)))) + let set_options name options = + if options <> [] then + ignore (call ~log:true ("-s" :: name :: (List.concat (List.map (fun (k, v) -> [k; v]) options)))) - let set_offload name options = - if options <> [] then - ignore (call ~log:true ("-K" :: name :: (List.concat (List.map (fun (k, v) -> [k; v]) options)))) + let set_offload name options = + if options <> [] then + ignore (call ~log:true ("-K" :: name :: (List.concat (List.map (fun (k, v) -> [k; v]) options)))) end module Dracut = struct - let call ?(log=false) args = - call_script ~timeout:(Some !dracut_timeout) ~log_successful_output:log !dracut args - - let rebuild_initrd () = - try - info "Building initrd..."; - let img_name = call_script !uname ["-r"] |> String.trim in - call ["-f"; Printf.sprintf "/boot/initrd-%s.img" img_name; img_name] |> ignore; - Result.Ok () - with _ -> Result.Error (Fail_to_rebuild_initrd, "Error occurs in building initrd") + let call ?(log=false) args = + call_script ~timeout:(Some !dracut_timeout) ~log_successful_output:log !dracut args + + let rebuild_initrd () = + try + info "Building initrd..."; + let img_name = call_script !uname ["-r"] |> String.trim in + call ["-f"; Printf.sprintf "/boot/initrd-%s.img" img_name; img_name] |> ignore; + Result.Ok () + with _ -> Result.Error (Fail_to_rebuild_initrd, "Error occurs in building initrd") end module Modinfo = struct - let call ?(log=false) args = - call_script ~log_successful_output:log !modinfo args - - let is_param_array driver param_name = - try - let out = call ["--parameter"; driver] - |> String.trim |> String.split_on_char '\n' - in - let re = Re.Perl.compile_pat "\\((.*)\\)$" in - let has_array_of str = - match Re.exec_opt re str with - | None -> false - | Some x -> Re.Group.get x 1 |> Astring.String.is_infix ~affix:"array of" - in - Ok (List.exists (fun line -> - match Astring.String.cut ~sep:":" line with - | None -> false - | Some (param, description) -> String.trim param = param_name && has_array_of description - ) out - ) - with _ -> Error (Other, Printf.sprintf "Failed to determine if VF param of driver '%s' is an array" driver) + let call ?(log=false) args = + call_script ~log_successful_output:log !modinfo args + + let is_param_array driver param_name = + try + let out = call ["--parameter"; driver] + |> String.trim |> String.split_on_char '\n' + in + let re = Re.Perl.compile_pat "\\((.*)\\)$" in + let has_array_of str = + match Re.exec_opt re str with + | None -> false + | Some x -> Re.Group.get x 1 |> Astring.String.is_infix ~affix:"array of" + in + Ok (List.exists (fun line -> + match Astring.String.cut ~sep:":" line with + | None -> false + | Some (param, description) -> String.trim param = param_name && has_array_of description + ) out + ) + with _ -> Error (Other, Printf.sprintf "Failed to determine if VF param of driver '%s' is an array" driver) end module Modprobe = struct - let getpath driver = - Printf.sprintf "/etc/modprobe.d/%s.conf" driver + let getpath driver = + Printf.sprintf "/etc/modprobe.d/%s.conf" driver - let write_conf_file driver content = - try - Unixext.write_string_to_file (getpath driver) (String.concat "\n" content); - Result.Ok () - with _ -> Result.Error (Fail_to_write_modprobe_cfg, "Failed to write modprobe configuration file for: " ^ driver) + let write_conf_file driver content = + try + Unixext.write_string_to_file (getpath driver) (String.concat "\n" content); + Result.Ok () + with _ -> Result.Error (Fail_to_write_modprobe_cfg, "Failed to write modprobe configuration file for: " ^ driver) - (* + (* For a igb driver, the module config file will be at path `/etc/modprobe.d/igb.conf` The module config file is like: # VFs-param: max_vfs @@ -1376,98 +1376,98 @@ module Modprobe = struct "igb" -> "VFs-maxvfs-by-user" -> None "igb" -> "Not existed comments" -> None *) - let get_config_from_comments driver = - try - let open Xapi_stdext_std.Listext in - Unixext.read_lines (getpath driver) - |> List.filter_map (fun x -> - let line = String.trim x in - if not (Astring.String.is_prefix ~affix:("# ") line) - then None - else - match Astring.String.cut ~sep:":" (Astring.String.with_range ~first:2 line) with - | None -> None - | Some (k, v) when String.trim k = "" || String.trim v = "" -> None - | Some (k, v) -> Some (String.trim k, String.trim v) - ) - with _ -> [] - - (* this function not returning None means that the driver doesn't suppport sysfs. - If a driver doesn't support sysfs, then we add VF_param into its driver modprobe - configuration. Therefore, from XAPI's perspective, if Modprobe.get_vf_param is - not None, the driver definitely should use modprobe other than sysfs, - and if Modprobe.get_vf_param is None, we just simple try sysfs. *) - let get_vf_param config = - try - Some (List.assoc "VFs-param" config) - with _ -> None - - let get_maxvfs driver config = - let get_default_maxvfs config = - try - Some (List.assoc "VFs-maxvfs-by-default" config |> int_of_string) - with _ -> None - in - let get_user_defined_maxvfs config = - try - Some (List.assoc "VFs-maxvfs-by-user" config |> int_of_string) - with _ -> None - in - match get_default_maxvfs config, get_user_defined_maxvfs config with - | Some a, None -> Result.Ok a - | Some a, Some b -> Result.Ok (min a b) (* If users also define a maxvfs, we will use the smaller one *) - | _ -> Result.Error (Fail_to_get_maxvfs, "Fail to get maxvfs for "^ driver) - - let config_sriov driver vf_param maxvfs = - let open Rresult.R.Infix in - Modinfo.is_param_array driver vf_param >>= fun is_array -> - (* To enable SR-IOV via modprobe configuration, we first determine if the driver requires - in the configuration an array like `options igb max_vfs=7,7,7,7` or a single value - like `options igb max_vfs=7`. If an array is required, this repeat times equals to - the number of devices with the same driver. - *) - let repeat = if is_array then Sysfs.get_dev_nums_with_same_driver driver else 1 in - begin - if repeat > 0 then Result.Ok ( - Array.make repeat (string_of_int maxvfs) - |> Array.to_list - |> String.concat ",") - else Result.Error (Other, "Fail to generate options for maxvfs for " ^ driver) - end >>= fun option -> - let need_rebuild_initrd = ref false in - let has_probe_conf = ref false in - let parse_single_line s = - let parse_driver_options s = - match Astring.String.cut ~sep:"=" s with - (* has SR-IOV configuration but the max_vfs is exactly what we want to set, so no changes and return s *) - | Some (k, v) when k = vf_param && v = option -> has_probe_conf := true; s - (* has SR-IOV configuration and we need change it to expected option *) - | Some (k, v) when k = vf_param -> - has_probe_conf := true; - need_rebuild_initrd := true; - debug "change SR-IOV options from [%s=%s] to [%s=%s]" k v k option; - Printf.sprintf "%s=%s" vf_param option - (* we do not care the lines without SR-IOV configurations *) - | _ -> s - in - let trimed_s = String.trim s in - if Re.execp (Re.Perl.compile_pat ("options[ \\t]+" ^ driver)) trimed_s then - let driver_options = Re.split (Re.Perl.compile_pat "[ \\t]+") trimed_s in - List.map parse_driver_options driver_options - |> String.concat " " - else - trimed_s - in - let lines = try Unixext.read_lines (getpath driver) with _ -> [] in - let new_conf = List.map parse_single_line lines in - match !has_probe_conf, !need_rebuild_initrd with - | true, true -> - write_conf_file driver new_conf >>= fun () -> - Dracut.rebuild_initrd () - | false, false -> - let new_option_line = Printf.sprintf "options %s %s=%s" driver vf_param option in - write_conf_file driver (new_conf @ [new_option_line]) >>= fun () -> - Dracut.rebuild_initrd () - | true, false -> Result.Ok () (* already have modprobe configuration and no need to change *) - | false, true -> Result.Error (Other, "enabling SR-IOV via modprobe never comes here for: " ^ driver) + let get_config_from_comments driver = + try + let open Xapi_stdext_std.Listext in + Unixext.read_lines (getpath driver) + |> List.filter_map (fun x -> + let line = String.trim x in + if not (Astring.String.is_prefix ~affix:("# ") line) + then None + else + match Astring.String.cut ~sep:":" (Astring.String.with_range ~first:2 line) with + | None -> None + | Some (k, v) when String.trim k = "" || String.trim v = "" -> None + | Some (k, v) -> Some (String.trim k, String.trim v) + ) + with _ -> [] + + (* this function not returning None means that the driver doesn't suppport sysfs. + If a driver doesn't support sysfs, then we add VF_param into its driver modprobe + configuration. Therefore, from XAPI's perspective, if Modprobe.get_vf_param is + not None, the driver definitely should use modprobe other than sysfs, + and if Modprobe.get_vf_param is None, we just simple try sysfs. *) + let get_vf_param config = + try + Some (List.assoc "VFs-param" config) + with _ -> None + + let get_maxvfs driver config = + let get_default_maxvfs config = + try + Some (List.assoc "VFs-maxvfs-by-default" config |> int_of_string) + with _ -> None + in + let get_user_defined_maxvfs config = + try + Some (List.assoc "VFs-maxvfs-by-user" config |> int_of_string) + with _ -> None + in + match get_default_maxvfs config, get_user_defined_maxvfs config with + | Some a, None -> Result.Ok a + | Some a, Some b -> Result.Ok (min a b) (* If users also define a maxvfs, we will use the smaller one *) + | _ -> Result.Error (Fail_to_get_maxvfs, "Fail to get maxvfs for "^ driver) + + let config_sriov driver vf_param maxvfs = + let open Rresult.R.Infix in + Modinfo.is_param_array driver vf_param >>= fun is_array -> + (* To enable SR-IOV via modprobe configuration, we first determine if the driver requires + in the configuration an array like `options igb max_vfs=7,7,7,7` or a single value + like `options igb max_vfs=7`. If an array is required, this repeat times equals to + the number of devices with the same driver. + *) + let repeat = if is_array then Sysfs.get_dev_nums_with_same_driver driver else 1 in + begin + if repeat > 0 then Result.Ok ( + Array.make repeat (string_of_int maxvfs) + |> Array.to_list + |> String.concat ",") + else Result.Error (Other, "Fail to generate options for maxvfs for " ^ driver) + end >>= fun option -> + let need_rebuild_initrd = ref false in + let has_probe_conf = ref false in + let parse_single_line s = + let parse_driver_options s = + match Astring.String.cut ~sep:"=" s with + (* has SR-IOV configuration but the max_vfs is exactly what we want to set, so no changes and return s *) + | Some (k, v) when k = vf_param && v = option -> has_probe_conf := true; s + (* has SR-IOV configuration and we need change it to expected option *) + | Some (k, v) when k = vf_param -> + has_probe_conf := true; + need_rebuild_initrd := true; + debug "change SR-IOV options from [%s=%s] to [%s=%s]" k v k option; + Printf.sprintf "%s=%s" vf_param option + (* we do not care the lines without SR-IOV configurations *) + | _ -> s + in + let trimed_s = String.trim s in + if Re.execp (Re.Perl.compile_pat ("options[ \\t]+" ^ driver)) trimed_s then + let driver_options = Re.split (Re.Perl.compile_pat "[ \\t]+") trimed_s in + List.map parse_driver_options driver_options + |> String.concat " " + else + trimed_s + in + let lines = try Unixext.read_lines (getpath driver) with _ -> [] in + let new_conf = List.map parse_single_line lines in + match !has_probe_conf, !need_rebuild_initrd with + | true, true -> + write_conf_file driver new_conf >>= fun () -> + Dracut.rebuild_initrd () + | false, false -> + let new_option_line = Printf.sprintf "options %s %s=%s" driver vf_param option in + write_conf_file driver (new_conf @ [new_option_line]) >>= fun () -> + Dracut.rebuild_initrd () + | true, false -> Result.Ok () (* already have modprobe configuration and no need to change *) + | false, true -> Result.Error (Other, "enabling SR-IOV via modprobe never comes here for: " ^ driver) end diff --git a/networkd/network_monitor.ml b/networkd/network_monitor.ml index dc4536e5b..15dc02eb4 100644 --- a/networkd/network_monitor.ml +++ b/networkd/network_monitor.ml @@ -16,8 +16,8 @@ open Network_interface include Network_stats let write_stats stats = - let payload = stats |> Rpcmarshal.marshal typ_of_stats_t |> Jsonrpc.to_string in - let checksum = payload |> Digest.string |> Digest.to_hex in - let length = String.length payload in - let data = Printf.sprintf "%s%s%08x%s" magic checksum length payload in - Xapi_stdext_unix.Unixext.write_string_to_file stats_file (data) + let payload = stats |> Rpcmarshal.marshal typ_of_stats_t |> Jsonrpc.to_string in + let checksum = payload |> Digest.string |> Digest.to_hex in + let length = String.length payload in + let data = Printf.sprintf "%s%s%08x%s" magic checksum length payload in + Xapi_stdext_unix.Unixext.write_string_to_file stats_file (data) diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index c91453583..e238299f5 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -24,301 +24,301 @@ open D let bonds_status : (string, (int * int)) Hashtbl.t = Hashtbl.create 10 let monitor_whitelist = ref [ - "eth"; - "vif"; (* This includes "tap" owing to the use of standardise_name below *) -] + "eth"; + "vif"; (* This includes "tap" owing to the use of standardise_name below *) + ] let xapi_rpc xml = let open Xmlrpc_client in XMLRPC_protocol.rpc ~srcstr:"xcp-networkd" ~dststr:"xapi" ~transport:(Unix "/var/xapi/xapi") ~http:(xmlrpc ~version:"1.0" "/") xml let send_bond_change_alert dev interfaces message = - let ifaces = String.concat "+" (List.sort String.compare interfaces) in - let module XenAPI = Client.Client in - let session_id = XenAPI.Session.login_with_password - ~rpc:xapi_rpc ~uname:"" ~pwd:"" ~version:"1.4" ~originator:("xcp-networkd v" ^ Version.version) in - Pervasiveext.finally - (fun _ -> - let obj_uuid = Inventory.lookup Inventory._installation_uuid in - let body = Printf.sprintf "The status of the %s bond %s" ifaces message in - try - let (name, priority) = Api_messages.bond_status_changed in - let (_ : API.ref_message) = XenAPI.Message.create ~rpc:xapi_rpc ~session_id - ~name ~priority ~cls:`Host ~obj_uuid ~body in () - with _ -> - warn "Exception sending a bond-status-change alert." - ) - (fun _ -> XenAPI.Session.logout ~rpc:xapi_rpc ~session_id) + let ifaces = String.concat "+" (List.sort String.compare interfaces) in + let module XenAPI = Client.Client in + let session_id = XenAPI.Session.login_with_password + ~rpc:xapi_rpc ~uname:"" ~pwd:"" ~version:"1.4" ~originator:("xcp-networkd v" ^ Version.version) in + Pervasiveext.finally + (fun _ -> + let obj_uuid = Inventory.lookup Inventory._installation_uuid in + let body = Printf.sprintf "The status of the %s bond %s" ifaces message in + try + let (name, priority) = Api_messages.bond_status_changed in + let (_ : API.ref_message) = XenAPI.Message.create ~rpc:xapi_rpc ~session_id + ~name ~priority ~cls:`Host ~obj_uuid ~body in () + with _ -> + warn "Exception sending a bond-status-change alert." + ) + (fun _ -> XenAPI.Session.logout ~rpc:xapi_rpc ~session_id) let check_for_changes ~(dev : string) ~(stat : Network_monitor.iface_stats) = - let open Network_monitor in - match Astring.String.is_prefix ~affix:"vif" dev with true -> () | false -> - if stat.nb_links > 1 then ( (* It is a bond. *) - if Hashtbl.mem bonds_status dev then ( (* Seen before. *) - let nb_links_old, links_up_old = Hashtbl.find bonds_status dev in - if links_up_old <> stat.links_up then ( - info "Bonds status changed: %s nb_links %d up %d up_old %d" dev stat.nb_links - stat.links_up links_up_old; - Hashtbl.replace bonds_status dev (stat.nb_links,stat.links_up); - let msg = Printf.sprintf "changed: %d/%d up (was %d/%d)" stat.links_up stat.nb_links - links_up_old nb_links_old in - try - send_bond_change_alert dev stat.interfaces msg - with e -> - debug "Error while sending alert BONDS_STATUS_CHANGED: %s\n%s" - (Printexc.to_string e) (Printexc.get_backtrace ()) - ) - ) else ( (* Seen for the first time. *) - Hashtbl.add bonds_status dev (stat.nb_links,stat.links_up); - info "New bonds status: %s nb_links %d up %d" dev stat.nb_links stat.links_up; - if stat.links_up <> stat.nb_links then - (let msg = Printf.sprintf "is: %d/%d up" stat.links_up stat.nb_links in - try - send_bond_change_alert dev stat.interfaces msg - with e -> - debug "Error while sending alert BONDS_STATUS_CHANGED: %s\n%s" - (Printexc.to_string e) (Printexc.get_backtrace ())) - ) - ) + let open Network_monitor in + match Astring.String.is_prefix ~affix:"vif" dev with true -> () | false -> + if stat.nb_links > 1 then ( (* It is a bond. *) + if Hashtbl.mem bonds_status dev then ( (* Seen before. *) + let nb_links_old, links_up_old = Hashtbl.find bonds_status dev in + if links_up_old <> stat.links_up then ( + info "Bonds status changed: %s nb_links %d up %d up_old %d" dev stat.nb_links + stat.links_up links_up_old; + Hashtbl.replace bonds_status dev (stat.nb_links,stat.links_up); + let msg = Printf.sprintf "changed: %d/%d up (was %d/%d)" stat.links_up stat.nb_links + links_up_old nb_links_old in + try + send_bond_change_alert dev stat.interfaces msg + with e -> + debug "Error while sending alert BONDS_STATUS_CHANGED: %s\n%s" + (Printexc.to_string e) (Printexc.get_backtrace ()) + ) + ) else ( (* Seen for the first time. *) + Hashtbl.add bonds_status dev (stat.nb_links,stat.links_up); + info "New bonds status: %s nb_links %d up %d" dev stat.nb_links stat.links_up; + if stat.links_up <> stat.nb_links then + (let msg = Printf.sprintf "is: %d/%d up" stat.links_up stat.nb_links in + try + send_bond_change_alert dev stat.interfaces msg + with e -> + debug "Error while sending alert BONDS_STATUS_CHANGED: %s\n%s" + (Printexc.to_string e) (Printexc.get_backtrace ())) + ) + ) let failed_again = ref false let standardise_name name = - try - let (d1,d2) = Scanf.sscanf name "tap%d.%d" - (fun d1 d2 -> d1,d2) in - let newname = Printf.sprintf "vif%d.%d" d1 d2 in - newname - with _ -> name + try + let (d1,d2) = Scanf.sscanf name "tap%d.%d" + (fun d1 d2 -> d1,d2) in + let newname = Printf.sprintf "vif%d.%d" d1 d2 in + newname + with _ -> name let get_link_stats () = - let open Network_monitor in - let open Netlink in - let s = Socket.alloc () in - Socket.connect s Socket.NETLINK_ROUTE; + let open Network_monitor in + let open Netlink in + let s = Socket.alloc () in + Socket.connect s Socket.NETLINK_ROUTE; - let cache = Link.cache_alloc s in - let links = Link.cache_to_list cache in - let links = - let is_whitelisted name = - List.exists (fun s -> Astring.String.is_prefix ~affix:s name) !monitor_whitelist - in - let is_vlan name = - Astring.String.is_prefix ~affix:"eth" name && String.contains name '.' - in - List.map (fun link -> - (standardise_name (Link.get_name link)), link - ) links |> - (* Only keep interfaces with prefixes on the whitelist, and exclude VLAN - devices (ethx.y). *) - List.filter (fun (name, _) -> - is_whitelisted name && not (is_vlan name) - ) - in + let cache = Link.cache_alloc s in + let links = Link.cache_to_list cache in + let links = + let is_whitelisted name = + List.exists (fun s -> Astring.String.is_prefix ~affix:s name) !monitor_whitelist + in + let is_vlan name = + Astring.String.is_prefix ~affix:"eth" name && String.contains name '.' + in + List.map (fun link -> + (standardise_name (Link.get_name link)), link + ) links |> + (* Only keep interfaces with prefixes on the whitelist, and exclude VLAN + devices (ethx.y). *) + List.filter (fun (name, _) -> + is_whitelisted name && not (is_vlan name) + ) + in - let devs = List.map (fun (name,link) -> - let convert x = Int64.of_int (Unsigned.UInt64.to_int x) in - let eth_stat = {default_stats with - rx_bytes = Link.get_stat link Link.RX_BYTES |> convert; - rx_pkts = Link.get_stat link Link.RX_PACKETS |> convert; - rx_errors = Link.get_stat link Link.RX_ERRORS |> convert; - tx_bytes = Link.get_stat link Link.TX_BYTES |> convert; - tx_pkts = Link.get_stat link Link.TX_PACKETS |> convert; - tx_errors = Link.get_stat link Link.TX_ERRORS |> convert; - } in - name, eth_stat - ) links in + let devs = List.map (fun (name,link) -> + let convert x = Int64.of_int (Unsigned.UInt64.to_int x) in + let eth_stat = {default_stats with + rx_bytes = Link.get_stat link Link.RX_BYTES |> convert; + rx_pkts = Link.get_stat link Link.RX_PACKETS |> convert; + rx_errors = Link.get_stat link Link.RX_ERRORS |> convert; + tx_bytes = Link.get_stat link Link.TX_BYTES |> convert; + tx_pkts = Link.get_stat link Link.TX_PACKETS |> convert; + tx_errors = Link.get_stat link Link.TX_ERRORS |> convert; + } in + name, eth_stat + ) links in - Cache.free cache; - Socket.close s; - Socket.free s; - devs + Cache.free cache; + Socket.close s; + Socket.free s; + devs let rec monitor dbg () = - let open Network_interface in - let open Network_monitor in - (try - let make_bond_info devs (name, interfaces) = - let devs' = List.filter (fun (name', _) -> List.mem name' interfaces) devs in - let eth_stat = {default_stats with - rx_bytes = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.rx_bytes) 0L devs'; - rx_pkts = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.rx_pkts) 0L devs'; - rx_errors = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.rx_errors) 0L devs'; - tx_bytes = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.tx_bytes) 0L devs'; - tx_pkts = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.tx_pkts) 0L devs'; - tx_errors = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.tx_errors) 0L devs'; - } in - name, eth_stat - in - let add_bonds bonds devs = - (List.map (make_bond_info devs) bonds) @ devs - in - let transform_taps devs = - let newdevnames = Xapi_stdext_std.Listext.List.setify (List.map fst devs) in - List.map (fun name -> - let devs' = List.filter (fun (n,x) -> n=name) devs in - let tot = List.fold_left (fun acc (_,b) -> - {default_stats with - rx_bytes = Int64.add acc.rx_bytes b.rx_bytes; - rx_pkts = Int64.add acc.rx_pkts b.rx_pkts; - rx_errors = Int64.add acc.rx_errors b.rx_errors; - tx_bytes = Int64.add acc.tx_bytes b.tx_bytes; - tx_pkts = Int64.add acc.tx_pkts b.tx_pkts; - tx_errors = Int64.add acc.tx_errors b.tx_errors} - ) default_stats devs' in - (name,tot) - ) newdevnames - in - let add_other_stats bonds devs = - List.map (fun (dev, stat) -> - if not (Astring.String.is_prefix ~affix:"vif" dev) then begin - let open Network_server.Bridge in - let bond_slaves = - if List.mem_assoc dev bonds then - get_bond_link_info () dbg dev - else - [] - in - let stat = - if bond_slaves = [] then - let carrier = Sysfs.get_carrier dev in - let speed, duplex = - if carrier then - Sysfs.get_status dev - else - (0, Duplex_unknown) - in - let pci_bus_path = Sysfs.get_pcibuspath dev in - let vendor_id, device_id = Sysfs.get_pci_ids dev in - let nb_links = 1 in - let links_up = if carrier then 1 else 0 in - let interfaces = [dev] in - {stat with carrier; speed; duplex; pci_bus_path; vendor_id; device_id; nb_links; links_up; interfaces} - else - let carrier = List.exists (fun info -> info.up) bond_slaves in - let speed, duplex = - let combine_duplex = function - | Duplex_full, Duplex_full -> Duplex_full - | Duplex_unknown, a | a, Duplex_unknown -> a - | _ -> Duplex_half - in - List.fold_left (fun (speed, duplex) info -> - try - if info.active then - let speed', duplex' = Sysfs.get_status info.slave in - speed + speed', combine_duplex (duplex, duplex') - else - speed, duplex - with _ -> - speed, duplex - ) (0, Duplex_unknown) bond_slaves - in - let pci_bus_path = "" in - let vendor_id, device_id = "", "" in - let nb_links = List.length bond_slaves in - let links_up = List.length (List.filter (fun info -> info.up) bond_slaves) in - let interfaces = List.map (fun info -> info.slave) bond_slaves in - {stat with carrier; speed; duplex; pci_bus_path; vendor_id; device_id; nb_links; links_up; interfaces} - in - check_for_changes ~dev ~stat; - dev, stat - end else - dev, stat - ) devs - in - let from_cache = true in - let bonds : (string * string list) list = Network_server.Bridge.get_all_bonds dbg from_cache in - let devs = - get_link_stats () |> - add_bonds bonds |> - transform_taps |> - add_other_stats bonds - in + let open Network_interface in + let open Network_monitor in + (try + let make_bond_info devs (name, interfaces) = + let devs' = List.filter (fun (name', _) -> List.mem name' interfaces) devs in + let eth_stat = {default_stats with + rx_bytes = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.rx_bytes) 0L devs'; + rx_pkts = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.rx_pkts) 0L devs'; + rx_errors = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.rx_errors) 0L devs'; + tx_bytes = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.tx_bytes) 0L devs'; + tx_pkts = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.tx_pkts) 0L devs'; + tx_errors = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.tx_errors) 0L devs'; + } in + name, eth_stat + in + let add_bonds bonds devs = + (List.map (make_bond_info devs) bonds) @ devs + in + let transform_taps devs = + let newdevnames = Xapi_stdext_std.Listext.List.setify (List.map fst devs) in + List.map (fun name -> + let devs' = List.filter (fun (n,x) -> n=name) devs in + let tot = List.fold_left (fun acc (_,b) -> + {default_stats with + rx_bytes = Int64.add acc.rx_bytes b.rx_bytes; + rx_pkts = Int64.add acc.rx_pkts b.rx_pkts; + rx_errors = Int64.add acc.rx_errors b.rx_errors; + tx_bytes = Int64.add acc.tx_bytes b.tx_bytes; + tx_pkts = Int64.add acc.tx_pkts b.tx_pkts; + tx_errors = Int64.add acc.tx_errors b.tx_errors} + ) default_stats devs' in + (name,tot) + ) newdevnames + in + let add_other_stats bonds devs = + List.map (fun (dev, stat) -> + if not (Astring.String.is_prefix ~affix:"vif" dev) then begin + let open Network_server.Bridge in + let bond_slaves = + if List.mem_assoc dev bonds then + get_bond_link_info () dbg dev + else + [] + in + let stat = + if bond_slaves = [] then + let carrier = Sysfs.get_carrier dev in + let speed, duplex = + if carrier then + Sysfs.get_status dev + else + (0, Duplex_unknown) + in + let pci_bus_path = Sysfs.get_pcibuspath dev in + let vendor_id, device_id = Sysfs.get_pci_ids dev in + let nb_links = 1 in + let links_up = if carrier then 1 else 0 in + let interfaces = [dev] in + {stat with carrier; speed; duplex; pci_bus_path; vendor_id; device_id; nb_links; links_up; interfaces} + else + let carrier = List.exists (fun info -> info.up) bond_slaves in + let speed, duplex = + let combine_duplex = function + | Duplex_full, Duplex_full -> Duplex_full + | Duplex_unknown, a | a, Duplex_unknown -> a + | _ -> Duplex_half + in + List.fold_left (fun (speed, duplex) info -> + try + if info.active then + let speed', duplex' = Sysfs.get_status info.slave in + speed + speed', combine_duplex (duplex, duplex') + else + speed, duplex + with _ -> + speed, duplex + ) (0, Duplex_unknown) bond_slaves + in + let pci_bus_path = "" in + let vendor_id, device_id = "", "" in + let nb_links = List.length bond_slaves in + let links_up = List.length (List.filter (fun info -> info.up) bond_slaves) in + let interfaces = List.map (fun info -> info.slave) bond_slaves in + {stat with carrier; speed; duplex; pci_bus_path; vendor_id; device_id; nb_links; links_up; interfaces} + in + check_for_changes ~dev ~stat; + dev, stat + end else + dev, stat + ) devs + in + let from_cache = true in + let bonds : (string * string list) list = Network_server.Bridge.get_all_bonds dbg from_cache in + let devs = + get_link_stats () |> + add_bonds bonds |> + transform_taps |> + add_other_stats bonds + in - if (List.length bonds) <> (Hashtbl.length bonds_status) then begin - let dead_bonds = Hashtbl.fold (fun k _ acc -> if List.mem_assoc k bonds then acc else k :: acc) - bonds_status [] in - List.iter (fun b -> info "Removing bond %s" b; Hashtbl.remove bonds_status b) dead_bonds - end; + if (List.length bonds) <> (Hashtbl.length bonds_status) then begin + let dead_bonds = Hashtbl.fold (fun k _ acc -> if List.mem_assoc k bonds then acc else k :: acc) + bonds_status [] in + List.iter (fun b -> info "Removing bond %s" b; Hashtbl.remove bonds_status b) dead_bonds + end; - write_stats devs; - failed_again := false - with e -> - if not !failed_again then begin - failed_again := true; - debug "Error while collecting stats (suppressing further errors): %s\n%s" - (Printexc.to_string e) (Printexc.get_backtrace ()) - end - ); + write_stats devs; + failed_again := false + with e -> + if not !failed_again then begin + failed_again := true; + debug "Error while collecting stats (suppressing further errors): %s\n%s" + (Printexc.to_string e) (Printexc.get_backtrace ()) + end + ); - Thread.delay interval; - monitor dbg () + Thread.delay interval; + monitor dbg () let watcher_m = Mutex.create () let watcher_pid = ref None let signal_networking_change () = - let module XenAPI = Client.Client in - let session = XenAPI.Session.slave_local_login_with_password ~rpc:xapi_rpc ~uname:"" ~pwd:"" in - Pervasiveext.finally - (fun () -> XenAPI.Host.signal_networking_change xapi_rpc session) - (fun () -> XenAPI.Session.local_logout xapi_rpc session) + let module XenAPI = Client.Client in + let session = XenAPI.Session.slave_local_login_with_password ~rpc:xapi_rpc ~uname:"" ~pwd:"" in + Pervasiveext.finally + (fun () -> XenAPI.Host.signal_networking_change xapi_rpc session) + (fun () -> XenAPI.Session.local_logout xapi_rpc session) (* Remove all outstanding reads on a file descriptor *) let clear_input fd = - let buf = Bytes.make 255 ' ' in - let rec loop () = - try - ignore (Unix.read fd buf 0 255); - loop () - with _ -> () - in - Unix.set_nonblock fd; - loop (); - Unix.clear_nonblock fd + let buf = Bytes.make 255 ' ' in + let rec loop () = + try + ignore (Unix.read fd buf 0 255); + loop () + with _ -> () + in + Unix.set_nonblock fd; + loop (); + Unix.clear_nonblock fd let ip_watcher () = - let cmd = Network_utils.iproute2 in - let args = ["monitor"; "address"] in - let readme, writeme = Unix.pipe () in - Mutex.execute watcher_m (fun () -> - watcher_pid := Some (Forkhelpers.safe_close_and_exec ~env:(Unix.environment ()) None (Some writeme) None [] cmd args) - ); - Unix.close writeme; - let in_channel = Unix.in_channel_of_descr readme in - let rec loop () = - let line = input_line in_channel in - (* Do not send events for link-local IPv6 addresses, and removed IPs *) - if Astring.String.is_infix ~affix:"inet" line && not (Astring.String.is_infix ~affix:"inet6 fe80" line) then begin - (* Ignore changes for the next second, since they usually come in bursts, - * and signal only once. *) - Thread.delay 1.; - clear_input readme; - signal_networking_change () - end; - loop () - in - while true do - try - info "(Re)started IP watcher thread"; - loop () - with e -> - warn "Error in IP watcher: %s\n%s" (Printexc.to_string e) (Printexc.get_backtrace ()) - done + let cmd = Network_utils.iproute2 in + let args = ["monitor"; "address"] in + let readme, writeme = Unix.pipe () in + Mutex.execute watcher_m (fun () -> + watcher_pid := Some (Forkhelpers.safe_close_and_exec ~env:(Unix.environment ()) None (Some writeme) None [] cmd args) + ); + Unix.close writeme; + let in_channel = Unix.in_channel_of_descr readme in + let rec loop () = + let line = input_line in_channel in + (* Do not send events for link-local IPv6 addresses, and removed IPs *) + if Astring.String.is_infix ~affix:"inet" line && not (Astring.String.is_infix ~affix:"inet6 fe80" line) then begin + (* Ignore changes for the next second, since they usually come in bursts, + * and signal only once. *) + Thread.delay 1.; + clear_input readme; + signal_networking_change () + end; + loop () + in + while true do + try + info "(Re)started IP watcher thread"; + loop () + with e -> + warn "Error in IP watcher: %s\n%s" (Printexc.to_string e) (Printexc.get_backtrace ()) + done let start () = - let dbg = "monitor_thread" in - Debug.with_thread_associated dbg (fun () -> - debug "Starting network monitor"; - let (_ : Thread.t) = Thread.create (monitor dbg) () in - let (_ : Thread.t) = Thread.create ip_watcher () in - () - ) () + let dbg = "monitor_thread" in + Debug.with_thread_associated dbg (fun () -> + debug "Starting network monitor"; + let (_ : Thread.t) = Thread.create (monitor dbg) () in + let (_ : Thread.t) = Thread.create ip_watcher () in + () + ) () let stop () = - Mutex.execute watcher_m (fun () -> - match !watcher_pid with - | None -> () - | Some pid -> Unix.kill (Forkhelpers.getpid pid) Sys.sigterm - ) + Mutex.execute watcher_m (fun () -> + match !watcher_pid with + | None -> () + | Some pid -> Unix.kill (Forkhelpers.getpid pid) Sys.sigterm + ) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 7f34f8e18..17df07038 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -30,1141 +30,1141 @@ let backend_kind = ref Openvswitch let enic_workaround_until_version = ref "2.3.0.30" let legacy_management_interface_start () = - try - ignore (call_script "/opt/xensource/libexec/legacy-management-interface" ["start"]); - debug "Upgrade: brought up interfaces using the old script. Xapi will sync up soon." - with e -> - debug "Error while configuring the management interface using the old script: %s\n%s" - (Printexc.to_string e) (Printexc.get_backtrace ()) + try + ignore (call_script "/opt/xensource/libexec/legacy-management-interface" ["start"]); + debug "Upgrade: brought up interfaces using the old script. Xapi will sync up soon." + with e -> + debug "Error while configuring the management interface using the old script: %s\n%s" + (Printexc.to_string e) (Printexc.get_backtrace ()) let write_config () = - try - Network_config.write_config !config - with Network_config.Write_error -> () + try + Network_config.write_config !config + with Network_config.Write_error -> () let read_config () = - try - config := Network_config.read_config (); - debug "Read configuration from networkd.db file." - with Network_config.Read_error -> - (* No configuration file found. *) - (* Perhaps it is an upgrade from the pre-networkd era. If network.dbcache exists, try to configure the - * management interface using the old scripts. *) - if (try Unix.access (Filename.concat "/var/lib/xcp" "network.dbcache") [Unix.F_OK]; true with _ -> false) then - legacy_management_interface_start () - else - (* Try to get the initial network setup from the first-boot data written by the host installer. *) - try - config := Network_config.read_management_conf (); - debug "Read configuration from management.conf file." - with Network_config.Read_error -> - debug "Could not interpret the configuration in management.conf" + try + config := Network_config.read_config (); + debug "Read configuration from networkd.db file." + with Network_config.Read_error -> + (* No configuration file found. *) + (* Perhaps it is an upgrade from the pre-networkd era. If network.dbcache exists, try to configure the + * management interface using the old scripts. *) + if (try Unix.access (Filename.concat "/var/lib/xcp" "network.dbcache") [Unix.F_OK]; true with _ -> false) then + legacy_management_interface_start () + else + (* Try to get the initial network setup from the first-boot data written by the host installer. *) + try + config := Network_config.read_management_conf (); + debug "Read configuration from management.conf file." + with Network_config.Read_error -> + debug "Could not interpret the configuration in management.conf" let on_shutdown signal = - let dbg = "shutdown" in - Debug.with_thread_associated dbg (fun () -> - debug "xcp-networkd caught signal %d; performing cleanup actions." signal; - write_config () - ) () + let dbg = "shutdown" in + Debug.with_thread_associated dbg (fun () -> + debug "xcp-networkd caught signal %d; performing cleanup actions." signal; + write_config () + ) () let on_timer () = - write_config () + write_config () let clear_state () = - config := Network_config.empty_config + config := Network_config.empty_config let reset_state () = - config := Network_config.read_management_conf () + config := Network_config.read_management_conf () let set_gateway_interface dbg name = - (* Update dhclient conf for interface on changing default gateway. - * If new default gateway is not same as gateway_interface from networkd.db then - * we need to remove gateway information from gateway_interface *) - begin match !config.gateway_interface with - | Some gateway_iface when name <> gateway_iface -> - let opts = - match !config.dns_interface with - | Some dns_iface when gateway_iface = dns_iface -> [`set_dns] - | _ -> [] - in - Dhclient.write_conf_file gateway_iface opts - | _ -> () - end; - debug "Setting gateway interface to %s" name; - config := {!config with gateway_interface = Some name} + (* Update dhclient conf for interface on changing default gateway. + * If new default gateway is not same as gateway_interface from networkd.db then + * we need to remove gateway information from gateway_interface *) + begin match !config.gateway_interface with + | Some gateway_iface when name <> gateway_iface -> + let opts = + match !config.dns_interface with + | Some dns_iface when gateway_iface = dns_iface -> [`set_dns] + | _ -> [] + in + Dhclient.write_conf_file gateway_iface opts + | _ -> () + end; + debug "Setting gateway interface to %s" name; + config := {!config with gateway_interface = Some name} let set_dns_interface dbg name = - debug "Setting DNS interface to %s" name; - config := {!config with dns_interface = Some name} + debug "Setting DNS interface to %s" name; + config := {!config with dns_interface = Some name} (* Returns `true` if vs1 is older than vs2 *) let is_older_version vs1 vs2 () = - try - let list_of_version vs = List.map int_of_string (Astring.String.cuts ~empty:false ~sep:"." vs) in - let rec loop vs1' vs2' = - match vs1', vs2' with - | [], _ | _, [] -> false - | a :: _, b :: _ when a < b -> true - | _ :: tl1, _ :: tl2 -> loop tl1 tl2 - in - loop (list_of_version vs1) (list_of_version vs2) - with _ -> - warn "Failed to compare driver version."; - false + try + let list_of_version vs = List.map int_of_string (Astring.String.cuts ~empty:false ~sep:"." vs) in + let rec loop vs1' vs2' = + match vs1', vs2' with + | [], _ | _, [] -> false + | a :: _, b :: _ when a < b -> true + | _ :: tl1, _ :: tl2 -> loop tl1 tl2 + in + loop (list_of_version vs1) (list_of_version vs2) + with _ -> + warn "Failed to compare driver version."; + false (* The enic driver is for Cisco UCS devices. The current driver adds VLAN0 headers * to all incoming packets, which confuses certain guests OSes. The workaround * constitutes adding a VLAN0 Linux device to strip those headers again. - *) +*) let need_enic_workaround () = - !backend_kind = Bridge && List.mem "enic" (Sysfs.list_drivers ()) && (!enic_workaround_until_version <> "") && ( - match Sysfs.get_driver_version "enic" () with - | Some vs -> (is_older_version vs !enic_workaround_until_version ()) - | None -> false ) + !backend_kind = Bridge && List.mem "enic" (Sysfs.list_drivers ()) && (!enic_workaround_until_version <> "") && ( + match Sysfs.get_driver_version "enic" () with + | Some vs -> (is_older_version vs !enic_workaround_until_version ()) + | None -> false ) module Sriov = struct - open S.Sriov + open S.Sriov -let get_capabilities dev = - let open Rresult.R.Infix in + let get_capabilities dev = + let open Rresult.R.Infix in let maxvfs_modprobe = - Sysfs.get_driver_name_err dev >>= fun driver -> - Modprobe.get_config_from_comments driver - |> Modprobe.get_maxvfs driver + Sysfs.get_driver_name_err dev >>= fun driver -> + Modprobe.get_config_from_comments driver + |> Modprobe.get_maxvfs driver and maxvfs_sysfs = Sysfs.get_sriov_maxvfs dev in let is_support = - match maxvfs_modprobe, maxvfs_sysfs with - | Ok v, _ -> v > 0 - | Error _ , Ok v -> v > 0 - | _ -> false + match maxvfs_modprobe, maxvfs_sysfs with + | Ok v, _ -> v > 0 + | Error _ , Ok v -> v > 0 + | _ -> false in if is_support then ["sriov"] else [] - let config_sriov ~enable dev = - let open Rresult.R.Infix in - Sysfs.get_driver_name_err dev >>= fun driver -> - let config = Modprobe.get_config_from_comments driver in - match Modprobe.get_vf_param config with - | Some vf_param -> - debug "enable SR-IOV on a device: %s via modprobe" dev; - (if enable then Modprobe.get_maxvfs driver config else Ok 0) >>= fun numvfs -> - (* CA-287340: Even if the current numvfs equals to the target numvfs, - it is still needed to update SR-IOV modprobe config file, as the - SR-IOV enabing takes effect after reboot. For example, a user - enables SR-IOV and disables it immediately without a reboot.*) - Modprobe.config_sriov driver vf_param numvfs >>= fun _ -> - if numvfs = Sysfs.get_sriov_numvfs dev then - Ok Modprobe_successful - else - Ok Modprobe_successful_requires_reboot - | None -> - debug "enable SR-IOV on a device: %s via sysfs" dev; - begin - if enable then Sysfs.get_sriov_maxvfs dev - else Sysfs.unbind_child_vfs dev >>= fun () -> Ok 0 - end >>= fun numvfs -> - Sysfs.set_sriov_numvfs dev numvfs >>= fun _ -> - Ok Sysfs_successful - - let enable dbg name = - Debug.with_thread_associated dbg (fun () -> - debug "Enable network SR-IOV by name: %s" name; - match config_sriov ~enable:true name with - | Ok t -> (Ok t:enable_result) - | Result.Error (_, msg) -> warn "Failed to enable SR-IOV on %s with error: %s" name msg; Error msg - ) () - - let disable dbg name = - Debug.with_thread_associated dbg (fun () -> - debug "Disable network SR-IOV by name: %s" name; - match config_sriov ~enable:false name with - | Ok _ -> (Ok:disable_result) - | Result.Error (_, msg) -> warn "Failed to disable SR-IOV on %s with error: %s" name msg; Error msg - ) () - - let make_vf_conf_internal pcibuspath mac vlan rate = - let config_or_otherwise_reset config_f reset_f = function - | None -> reset_f () - | Some a -> config_f a - in - let open Rresult.R.Infix in - Sysfs.parent_device_of_vf pcibuspath >>= fun dev -> - Sysfs.device_index_of_vf dev pcibuspath >>= fun index -> - config_or_otherwise_reset (Ip.set_vf_mac dev index) - (fun () -> Result.Ok ()) mac >>= fun () -> - (* In order to ensure the Networkd to be idempotent, configuring VF with no VLAN and rate - have to reset vlan and rate, since the VF might have previous configuration. Refering to - http://gittup.org/cgi-bin/man/man2html?ip-link+8, set VLAN and rate to 0 means to reset them *) - config_or_otherwise_reset (Ip.set_vf_vlan dev index) - (fun () -> Ip.set_vf_vlan dev index 0) vlan >>= fun () -> - config_or_otherwise_reset (Ip.set_vf_rate dev index) - (fun () -> Ip.set_vf_rate dev index 0) rate - - let make_vf_config dbg pci_address (vf_info : sriov_pci_t) = - Debug.with_thread_associated dbg (fun () -> - let vlan = Opt.map Int64.to_int vf_info.vlan - and rate = Opt.map Int64.to_int vf_info.rate - and pcibuspath = Xcp_pci.string_of_address pci_address in - debug "Config VF with pci address: %s" pcibuspath; - match make_vf_conf_internal pcibuspath vf_info.mac vlan rate with - | Result.Ok () -> (Ok:config_result) - | Result.Error (Fail_to_set_vf_rate, msg) -> - debug "%s" msg; - Error Config_vf_rate_not_supported - | Result.Error (_, msg) -> debug "%s" msg; Error (Unknown msg) - ) () + let config_sriov ~enable dev = + let open Rresult.R.Infix in + Sysfs.get_driver_name_err dev >>= fun driver -> + let config = Modprobe.get_config_from_comments driver in + match Modprobe.get_vf_param config with + | Some vf_param -> + debug "enable SR-IOV on a device: %s via modprobe" dev; + (if enable then Modprobe.get_maxvfs driver config else Ok 0) >>= fun numvfs -> + (* CA-287340: Even if the current numvfs equals to the target numvfs, + it is still needed to update SR-IOV modprobe config file, as the + SR-IOV enabing takes effect after reboot. For example, a user + enables SR-IOV and disables it immediately without a reboot.*) + Modprobe.config_sriov driver vf_param numvfs >>= fun _ -> + if numvfs = Sysfs.get_sriov_numvfs dev then + Ok Modprobe_successful + else + Ok Modprobe_successful_requires_reboot + | None -> + debug "enable SR-IOV on a device: %s via sysfs" dev; + begin + if enable then Sysfs.get_sriov_maxvfs dev + else Sysfs.unbind_child_vfs dev >>= fun () -> Ok 0 + end >>= fun numvfs -> + Sysfs.set_sriov_numvfs dev numvfs >>= fun _ -> + Ok Sysfs_successful + + let enable dbg name = + Debug.with_thread_associated dbg (fun () -> + debug "Enable network SR-IOV by name: %s" name; + match config_sriov ~enable:true name with + | Ok t -> (Ok t:enable_result) + | Result.Error (_, msg) -> warn "Failed to enable SR-IOV on %s with error: %s" name msg; Error msg + ) () + + let disable dbg name = + Debug.with_thread_associated dbg (fun () -> + debug "Disable network SR-IOV by name: %s" name; + match config_sriov ~enable:false name with + | Ok _ -> (Ok:disable_result) + | Result.Error (_, msg) -> warn "Failed to disable SR-IOV on %s with error: %s" name msg; Error msg + ) () + + let make_vf_conf_internal pcibuspath mac vlan rate = + let config_or_otherwise_reset config_f reset_f = function + | None -> reset_f () + | Some a -> config_f a + in + let open Rresult.R.Infix in + Sysfs.parent_device_of_vf pcibuspath >>= fun dev -> + Sysfs.device_index_of_vf dev pcibuspath >>= fun index -> + config_or_otherwise_reset (Ip.set_vf_mac dev index) + (fun () -> Result.Ok ()) mac >>= fun () -> + (* In order to ensure the Networkd to be idempotent, configuring VF with no VLAN and rate + have to reset vlan and rate, since the VF might have previous configuration. Refering to + http://gittup.org/cgi-bin/man/man2html?ip-link+8, set VLAN and rate to 0 means to reset them *) + config_or_otherwise_reset (Ip.set_vf_vlan dev index) + (fun () -> Ip.set_vf_vlan dev index 0) vlan >>= fun () -> + config_or_otherwise_reset (Ip.set_vf_rate dev index) + (fun () -> Ip.set_vf_rate dev index 0) rate + + let make_vf_config dbg pci_address (vf_info : sriov_pci_t) = + Debug.with_thread_associated dbg (fun () -> + let vlan = Opt.map Int64.to_int vf_info.vlan + and rate = Opt.map Int64.to_int vf_info.rate + and pcibuspath = Xcp_pci.string_of_address pci_address in + debug "Config VF with pci address: %s" pcibuspath; + match make_vf_conf_internal pcibuspath vf_info.mac vlan rate with + | Result.Ok () -> (Ok:config_result) + | Result.Error (Fail_to_set_vf_rate, msg) -> + debug "%s" msg; + Error Config_vf_rate_not_supported + | Result.Error (_, msg) -> debug "%s" msg; Error (Unknown msg) + ) () end module Interface = struct - let get_config name = - get_config !config.interface_config default_interface name - - let update_config name data = - config := {!config with interface_config = update_config !config.interface_config name data} - - let get_all dbg () = - Debug.with_thread_associated dbg (fun () -> - Sysfs.list () - ) () - - let exists dbg name = - Debug.with_thread_associated dbg (fun () -> - List.mem name (Sysfs.list ()) - ) () - - let get_mac dbg name = - Debug.with_thread_associated dbg (fun () -> - match Linux_bonding.get_bond_master_of name with - | Some master -> Proc.get_bond_slave_mac master name - | None -> Ip.get_mac name - ) () - let get_pci_bus_path dbg name = - Debug.with_thread_associated dbg (fun () -> - Sysfs.get_pcibuspath name - ) () - - let is_up dbg name = - Debug.with_thread_associated dbg (fun () -> - if List.mem name (Sysfs.list ()) then - Ip.is_up name - else - false - ) () - - let get_ipv4_addr dbg name = - Debug.with_thread_associated dbg (fun () -> - Ip.get_ipv4 name - ) () - - let set_ipv4_conf dbg name conf = - Debug.with_thread_associated dbg (fun () -> - debug "Configuring IPv4 address for %s: %s" name (conf |> Rpcmarshal.marshal typ_of_ipv4 |> Jsonrpc.to_string); - update_config name {(get_config name) with ipv4_conf = conf}; - match conf with - | None4 -> - if List.mem name (Sysfs.list ()) then begin - if Dhclient.is_running name then - ignore (Dhclient.stop name); - Ip.flush_ip_addr name - end - | DHCP4 -> - let open Xapi_stdext_monadic in - let gateway = Opt.default [] (Opt.map (fun n -> [`gateway n]) !config.gateway_interface) in - let dns = - if !config.dns_interface = None || !config.dns_interface = Some name then begin - debug "%s is the DNS interface" name; - [`set_dns] - end else begin - debug "%s is NOT the DNS interface" name; - [] - end - in - let options = gateway @ dns in - Dhclient.ensure_running name options - | Static4 addrs -> - if Dhclient.is_running name then begin - ignore (Dhclient.stop name); - Ip.flush_ip_addr name - end; - (* the function is meant to be idempotent and we - * want to avoid CA-239919 *) - let cur_addrs = Ip.get_ipv4 name in - let rm_addrs = Xapi_stdext_std.Listext.List.set_difference cur_addrs addrs in - let add_addrs = Xapi_stdext_std.Listext.List.set_difference addrs cur_addrs in - List.iter (Ip.del_ip_addr name) rm_addrs; - List.iter (Ip.set_ip_addr name) add_addrs - ) () - - let get_ipv4_gateway dbg name = - Debug.with_thread_associated dbg (fun () -> - let output = Ip.route_show ~version:Ip.V4 name in - try - let line = List.find (fun s -> Astring.String.is_prefix ~affix:"default via" s) (Astring.String.cuts ~empty:false ~sep:"\n" output) in - let addr = List.nth (Astring.String.cuts ~empty:false ~sep:" " line) 2 in - Some (Unix.inet_addr_of_string addr) - with Not_found -> None - ) () - - let set_ipv4_gateway _ dbg ~name ~address = - Debug.with_thread_associated dbg (fun () -> - debug "Configuring IPv4 gateway for %s: %s" name (Unix.string_of_inet_addr address); - update_config name {(get_config name) with ipv4_gateway = Some address}; - if !config.gateway_interface = None || !config.gateway_interface = Some name then begin - debug "%s is the default gateway interface" name; - Ip.set_gateway name address - end else - debug "%s is NOT the default gateway interface" name - ) () - - let get_ipv6_addr dbg name = - Debug.with_thread_associated dbg (fun () -> - Ip.get_ipv6 name - ) () - - let set_ipv6_conf _ dbg ~name ~conf = - Debug.with_thread_associated dbg (fun () -> - debug "Configuring IPv6 address for %s: %s" name (conf |> Rpcmarshal.marshal typ_of_ipv6 |> Jsonrpc.to_string); - update_config name {(get_config name) with ipv6_conf = conf}; - match conf with - | None6 -> - if List.mem name (Sysfs.list ()) then begin - if Dhclient.is_running ~ipv6:true name then - ignore (Dhclient.stop ~ipv6:true name); - Sysctl.set_ipv6_autoconf name false; - Ip.flush_ip_addr ~ipv6:true name - end - | Linklocal6 -> - if List.mem name (Sysfs.list ()) then begin - if Dhclient.is_running ~ipv6:true name then - ignore (Dhclient.stop ~ipv6:true name); - Sysctl.set_ipv6_autoconf name false; - Ip.flush_ip_addr ~ipv6:true name; - Ip.set_ipv6_link_local_addr name - end - | DHCP6 -> - if Dhclient.is_running ~ipv6:true name then - ignore (Dhclient.stop ~ipv6:true name); - Sysctl.set_ipv6_autoconf name false; - Ip.flush_ip_addr ~ipv6:true name; - Ip.set_ipv6_link_local_addr name; - ignore (Dhclient.start ~ipv6:true name []) - | Autoconf6 -> - if Dhclient.is_running ~ipv6:true name then - ignore (Dhclient.stop ~ipv6:true name); - Ip.flush_ip_addr ~ipv6:true name; - Ip.set_ipv6_link_local_addr name; - Sysctl.set_ipv6_autoconf name true; - (* Cannot link set down/up due to CA-89882 - IPv4 default route cleared *) - | Static6 addrs -> - if Dhclient.is_running ~ipv6:true name then - ignore (Dhclient.stop ~ipv6:true name); - Sysctl.set_ipv6_autoconf name false; - (* add the link_local and clean the old one only when needed *) - let cur_addrs = - let addrs = Ip.get_ipv6 name in - let maybe_link_local = Ip.split_addr (Ip.get_ipv6_link_local_addr name) in - match maybe_link_local with - | Some addr -> Xapi_stdext_std.Listext.List.setify (addr :: addrs) - | None -> addrs - in - let rm_addrs = Xapi_stdext_std.Listext.List.set_difference cur_addrs addrs in - let add_addrs = Xapi_stdext_std.Listext.List.set_difference addrs cur_addrs in - List.iter (Ip.del_ip_addr name) rm_addrs; - List.iter (Ip.set_ip_addr name) add_addrs - ) () - - let get_ipv6_gateway _ dbg ~name = - Debug.with_thread_associated dbg (fun () -> - let output = Ip.route_show ~version:Ip.V6 name in - try - let line = List.find (fun s -> Astring.String.is_prefix ~affix:"default via" s) (Astring.String.cuts ~empty:false ~sep:"\n" output) in - let addr = List.nth (Astring.String.cuts ~empty:false ~sep:" " line) 2 in - Some (Unix.inet_addr_of_string addr) - with Not_found -> None - ) () - - let set_ipv6_gateway _ dbg ~name ~address = - Debug.with_thread_associated dbg (fun () -> - debug "Configuring IPv6 gateway for %s: %s" name (Unix.string_of_inet_addr address); - update_config name {(get_config name) with ipv6_gateway = Some address}; - if !config.gateway_interface = None || !config.gateway_interface = Some name then begin - debug "%s is the default gateway interface" name; - Ip.set_gateway name address - end else - debug "%s is NOT the default gateway interface" name - ) () - - let set_ipv4_routes _ dbg ~name ~routes = - Debug.with_thread_associated dbg (fun () -> - debug "Configuring IPv4 static routes for %s: %s" name (String.concat ", " (List.map (fun r -> - Printf.sprintf "%s/%d/%s" (Unix.string_of_inet_addr r.subnet) r.netmask (Unix.string_of_inet_addr r.gateway)) routes)); - update_config name {(get_config name) with ipv4_routes = routes}; - List.iter (fun r -> Ip.set_route ~network:(r.subnet, r.netmask) name r.gateway) routes - ) () - - let get_dns dbg name = - Debug.with_thread_associated dbg (fun () -> - let nameservers, domains = Xapi_stdext_unix.Unixext.file_lines_fold (fun (nameservers, domains) line -> - if Astring.String.is_prefix ~affix:"nameserver" line then - let server = List.nth (Astring.String.fields ~empty:false line) 1 in - (Unix.inet_addr_of_string server) :: nameservers, domains - else if Astring.String.is_prefix ~affix:"search" line then - let domains = List.tl (Astring.String.fields ~empty:false line) in - nameservers, domains - else - nameservers, domains - ) ([], []) resolv_conf in - List.rev nameservers, domains - ) () - - let set_dns _ dbg ~name ~nameservers ~domains = - Debug.with_thread_associated dbg (fun () -> - update_config name {(get_config name) with dns = nameservers, domains}; - debug "Configuring DNS for %s: nameservers: [%s]; domains: [%s]" name - (String.concat ", " (List.map Unix.string_of_inet_addr nameservers)) - (String.concat ", " domains); - if (!config.dns_interface = None || !config.dns_interface = Some name) then begin - debug "%s is the DNS interface" name; - let domains' = if domains <> [] then ["search " ^ (String.concat " " domains)] else [] in - let nameservers' = List.map (fun ip -> "nameserver " ^ (Unix.string_of_inet_addr ip)) nameservers in - let lines = domains' @ nameservers' in - Xapi_stdext_unix.Unixext.write_string_to_file resolv_conf ((String.concat "\n" lines) ^ "\n") - end else - debug "%s is NOT the DNS interface" name - ) () - - let get_mtu dbg name = - Debug.with_thread_associated dbg (fun () -> - Ip.get_mtu name - ) () - - let set_mtu _ dbg ~name ~mtu = - Debug.with_thread_associated dbg (fun () -> - debug "Configuring MTU for %s: %d" name mtu; - update_config name {(get_config name) with mtu}; - match !backend_kind with - | Openvswitch -> - (try - ignore (Ovs.set_mtu name mtu) - with _ -> - Ip.link_set_mtu name mtu) - | Bridge -> Ip.link_set_mtu name mtu - ) () - - let set_ethtool_settings _ dbg ~name ~params = - Debug.with_thread_associated dbg (fun () -> - debug "Configuring ethtool settings for %s: %s" name - (String.concat ", " (List.map (fun (k, v) -> k ^ "=" ^ v) params)); - let add_defaults = List.filter (fun (k, v) -> not (List.mem_assoc k params)) default_interface.ethtool_settings in - let params = params @ add_defaults in - update_config name {(get_config name) with ethtool_settings = params}; - Ethtool.set_options name params - ) () - - let set_ethtool_offload _ dbg ~name ~params = - Debug.with_thread_associated dbg (fun () -> - debug "Configuring ethtool offload settings for %s: %s" name - (String.concat ", " (List.map (fun (k, v) -> k ^ "=" ^ v) params)); - let add_defaults = List.filter (fun (k, v) -> not (List.mem_assoc k params)) default_interface.ethtool_offload in - let params = params @ add_defaults in - update_config name {(get_config name) with ethtool_offload = params}; - Ethtool.set_offload name params - ) () - - let get_capabilities dbg name = - Debug.with_thread_associated dbg (fun () -> - Fcoe.get_capabilities name @ Sriov.get_capabilities name - ) () - - let is_connected dbg name = - Debug.with_thread_associated dbg (fun () -> - Sysfs.get_carrier name - ) () - - let is_physical dbg name = - Debug.with_thread_associated dbg (fun () -> - Sysfs.is_physical name - ) () - - let has_vlan dbg name vlan = - (* Identify the vlan is used by kernel which is unknown to XAPI *) - Debug.with_thread_associated dbg (fun () -> - List.exists (fun (_, v, p) -> v = vlan && p = name) (Proc.get_vlans ()) - ) () - - let bring_up _ dbg ~name = - Debug.with_thread_associated dbg (fun () -> - debug "Bringing up interface %s" name; - Ip.link_set_up name - ) () - - let bring_down dbg name = - Debug.with_thread_associated dbg (fun () -> - debug "Bringing down interface %s" name; - Ip.link_set_down name - ) () - - let is_persistent _ dbg ~name = - Debug.with_thread_associated dbg (fun () -> - (get_config name).persistent_i - ) () - - let set_persistent dbg name value = - Debug.with_thread_associated dbg (fun () -> - debug "Making interface %s %spersistent" name (if value then "" else "non-"); - update_config name {(get_config name) with persistent_i = value} - ) () - - let make_config dbg conservative config = - Debug.with_thread_associated dbg (fun () -> - (* Only attempt to configure interfaces that exist in the system *) - let all = get_all dbg () in - let config = List.filter (fun (name, _) -> List.mem name all) config in - (* Handle conservativeness *) - let config = - if conservative then begin - (* Do not touch non-persistent interfaces *) - debug "Only configuring persistent interfaces"; - List.filter (fun (name, interface) -> interface.persistent_i) config - end else - config - in - let config = - if need_enic_workaround () then - List.fold_left (fun accu (name, interface) -> - if (Sysfs.is_physical name && Linux_bonding.get_bond_master_of name = None) || Linux_bonding.is_bond_device name then - (name, interface) :: (Ip.vlan_name name 0, interface) :: accu - else - (name, interface) :: accu - ) [] config - else - config - in - debug "** Configuring the following interfaces: %s%s" (String.concat ", " (List.map (fun (name, _) -> name) config)) - (if conservative then " (best effort)" else ""); - let exec f = if conservative then (try f () with _ -> ()) else f () in - List.iter (function (name, ({ipv4_conf; ipv4_gateway; ipv6_conf; ipv6_gateway; ipv4_routes; dns=nameservers,domains; mtu; - ethtool_settings; ethtool_offload; _} as c)) -> - update_config name c; - exec (fun () -> - (* We only apply the DNS settings when in static IPv4 mode to avoid conflicts with DHCP mode. - * The `dns` field should really be an option type so that we don't have to derive the intention - * of the caller by looking at other fields. *) - match ipv4_conf with Static4 _ -> set_dns () dbg ~name ~nameservers ~domains | _ -> ()); - exec (fun () -> set_ipv4_conf dbg name ipv4_conf); - exec (fun () -> match ipv4_gateway with None -> () | Some gateway -> - set_ipv4_gateway () dbg ~name ~address:gateway); - (try set_ipv6_conf () dbg ~name ~conf:ipv6_conf with _ -> ()); - (try match ipv6_gateway with None -> () | Some gateway -> - set_ipv6_gateway () dbg ~name ~address:gateway with _ -> ()); - exec (fun () -> set_ipv4_routes () dbg ~name ~routes:ipv4_routes); - exec (fun () -> set_mtu () dbg ~name ~mtu); - exec (fun () -> bring_up () dbg ~name); - exec (fun () -> set_ethtool_settings () dbg ~name ~params:ethtool_settings); - exec (fun () -> set_ethtool_offload () dbg ~name ~params:ethtool_offload) - ) config - ) () + let get_config name = + get_config !config.interface_config default_interface name + + let update_config name data = + config := {!config with interface_config = update_config !config.interface_config name data} + + let get_all dbg () = + Debug.with_thread_associated dbg (fun () -> + Sysfs.list () + ) () + + let exists dbg name = + Debug.with_thread_associated dbg (fun () -> + List.mem name (Sysfs.list ()) + ) () + + let get_mac dbg name = + Debug.with_thread_associated dbg (fun () -> + match Linux_bonding.get_bond_master_of name with + | Some master -> Proc.get_bond_slave_mac master name + | None -> Ip.get_mac name + ) () + let get_pci_bus_path dbg name = + Debug.with_thread_associated dbg (fun () -> + Sysfs.get_pcibuspath name + ) () + + let is_up dbg name = + Debug.with_thread_associated dbg (fun () -> + if List.mem name (Sysfs.list ()) then + Ip.is_up name + else + false + ) () + + let get_ipv4_addr dbg name = + Debug.with_thread_associated dbg (fun () -> + Ip.get_ipv4 name + ) () + + let set_ipv4_conf dbg name conf = + Debug.with_thread_associated dbg (fun () -> + debug "Configuring IPv4 address for %s: %s" name (conf |> Rpcmarshal.marshal typ_of_ipv4 |> Jsonrpc.to_string); + update_config name {(get_config name) with ipv4_conf = conf}; + match conf with + | None4 -> + if List.mem name (Sysfs.list ()) then begin + if Dhclient.is_running name then + ignore (Dhclient.stop name); + Ip.flush_ip_addr name + end + | DHCP4 -> + let open Xapi_stdext_monadic in + let gateway = Opt.default [] (Opt.map (fun n -> [`gateway n]) !config.gateway_interface) in + let dns = + if !config.dns_interface = None || !config.dns_interface = Some name then begin + debug "%s is the DNS interface" name; + [`set_dns] + end else begin + debug "%s is NOT the DNS interface" name; + [] + end + in + let options = gateway @ dns in + Dhclient.ensure_running name options + | Static4 addrs -> + if Dhclient.is_running name then begin + ignore (Dhclient.stop name); + Ip.flush_ip_addr name + end; + (* the function is meant to be idempotent and we + * want to avoid CA-239919 *) + let cur_addrs = Ip.get_ipv4 name in + let rm_addrs = Xapi_stdext_std.Listext.List.set_difference cur_addrs addrs in + let add_addrs = Xapi_stdext_std.Listext.List.set_difference addrs cur_addrs in + List.iter (Ip.del_ip_addr name) rm_addrs; + List.iter (Ip.set_ip_addr name) add_addrs + ) () + + let get_ipv4_gateway dbg name = + Debug.with_thread_associated dbg (fun () -> + let output = Ip.route_show ~version:Ip.V4 name in + try + let line = List.find (fun s -> Astring.String.is_prefix ~affix:"default via" s) (Astring.String.cuts ~empty:false ~sep:"\n" output) in + let addr = List.nth (Astring.String.cuts ~empty:false ~sep:" " line) 2 in + Some (Unix.inet_addr_of_string addr) + with Not_found -> None + ) () + + let set_ipv4_gateway _ dbg ~name ~address = + Debug.with_thread_associated dbg (fun () -> + debug "Configuring IPv4 gateway for %s: %s" name (Unix.string_of_inet_addr address); + update_config name {(get_config name) with ipv4_gateway = Some address}; + if !config.gateway_interface = None || !config.gateway_interface = Some name then begin + debug "%s is the default gateway interface" name; + Ip.set_gateway name address + end else + debug "%s is NOT the default gateway interface" name + ) () + + let get_ipv6_addr dbg name = + Debug.with_thread_associated dbg (fun () -> + Ip.get_ipv6 name + ) () + + let set_ipv6_conf _ dbg ~name ~conf = + Debug.with_thread_associated dbg (fun () -> + debug "Configuring IPv6 address for %s: %s" name (conf |> Rpcmarshal.marshal typ_of_ipv6 |> Jsonrpc.to_string); + update_config name {(get_config name) with ipv6_conf = conf}; + match conf with + | None6 -> + if List.mem name (Sysfs.list ()) then begin + if Dhclient.is_running ~ipv6:true name then + ignore (Dhclient.stop ~ipv6:true name); + Sysctl.set_ipv6_autoconf name false; + Ip.flush_ip_addr ~ipv6:true name + end + | Linklocal6 -> + if List.mem name (Sysfs.list ()) then begin + if Dhclient.is_running ~ipv6:true name then + ignore (Dhclient.stop ~ipv6:true name); + Sysctl.set_ipv6_autoconf name false; + Ip.flush_ip_addr ~ipv6:true name; + Ip.set_ipv6_link_local_addr name + end + | DHCP6 -> + if Dhclient.is_running ~ipv6:true name then + ignore (Dhclient.stop ~ipv6:true name); + Sysctl.set_ipv6_autoconf name false; + Ip.flush_ip_addr ~ipv6:true name; + Ip.set_ipv6_link_local_addr name; + ignore (Dhclient.start ~ipv6:true name []) + | Autoconf6 -> + if Dhclient.is_running ~ipv6:true name then + ignore (Dhclient.stop ~ipv6:true name); + Ip.flush_ip_addr ~ipv6:true name; + Ip.set_ipv6_link_local_addr name; + Sysctl.set_ipv6_autoconf name true; + (* Cannot link set down/up due to CA-89882 - IPv4 default route cleared *) + | Static6 addrs -> + if Dhclient.is_running ~ipv6:true name then + ignore (Dhclient.stop ~ipv6:true name); + Sysctl.set_ipv6_autoconf name false; + (* add the link_local and clean the old one only when needed *) + let cur_addrs = + let addrs = Ip.get_ipv6 name in + let maybe_link_local = Ip.split_addr (Ip.get_ipv6_link_local_addr name) in + match maybe_link_local with + | Some addr -> Xapi_stdext_std.Listext.List.setify (addr :: addrs) + | None -> addrs + in + let rm_addrs = Xapi_stdext_std.Listext.List.set_difference cur_addrs addrs in + let add_addrs = Xapi_stdext_std.Listext.List.set_difference addrs cur_addrs in + List.iter (Ip.del_ip_addr name) rm_addrs; + List.iter (Ip.set_ip_addr name) add_addrs + ) () + + let get_ipv6_gateway _ dbg ~name = + Debug.with_thread_associated dbg (fun () -> + let output = Ip.route_show ~version:Ip.V6 name in + try + let line = List.find (fun s -> Astring.String.is_prefix ~affix:"default via" s) (Astring.String.cuts ~empty:false ~sep:"\n" output) in + let addr = List.nth (Astring.String.cuts ~empty:false ~sep:" " line) 2 in + Some (Unix.inet_addr_of_string addr) + with Not_found -> None + ) () + + let set_ipv6_gateway _ dbg ~name ~address = + Debug.with_thread_associated dbg (fun () -> + debug "Configuring IPv6 gateway for %s: %s" name (Unix.string_of_inet_addr address); + update_config name {(get_config name) with ipv6_gateway = Some address}; + if !config.gateway_interface = None || !config.gateway_interface = Some name then begin + debug "%s is the default gateway interface" name; + Ip.set_gateway name address + end else + debug "%s is NOT the default gateway interface" name + ) () + + let set_ipv4_routes _ dbg ~name ~routes = + Debug.with_thread_associated dbg (fun () -> + debug "Configuring IPv4 static routes for %s: %s" name (String.concat ", " (List.map (fun r -> + Printf.sprintf "%s/%d/%s" (Unix.string_of_inet_addr r.subnet) r.netmask (Unix.string_of_inet_addr r.gateway)) routes)); + update_config name {(get_config name) with ipv4_routes = routes}; + List.iter (fun r -> Ip.set_route ~network:(r.subnet, r.netmask) name r.gateway) routes + ) () + + let get_dns dbg name = + Debug.with_thread_associated dbg (fun () -> + let nameservers, domains = Xapi_stdext_unix.Unixext.file_lines_fold (fun (nameservers, domains) line -> + if Astring.String.is_prefix ~affix:"nameserver" line then + let server = List.nth (Astring.String.fields ~empty:false line) 1 in + (Unix.inet_addr_of_string server) :: nameservers, domains + else if Astring.String.is_prefix ~affix:"search" line then + let domains = List.tl (Astring.String.fields ~empty:false line) in + nameservers, domains + else + nameservers, domains + ) ([], []) resolv_conf in + List.rev nameservers, domains + ) () + + let set_dns _ dbg ~name ~nameservers ~domains = + Debug.with_thread_associated dbg (fun () -> + update_config name {(get_config name) with dns = nameservers, domains}; + debug "Configuring DNS for %s: nameservers: [%s]; domains: [%s]" name + (String.concat ", " (List.map Unix.string_of_inet_addr nameservers)) + (String.concat ", " domains); + if (!config.dns_interface = None || !config.dns_interface = Some name) then begin + debug "%s is the DNS interface" name; + let domains' = if domains <> [] then ["search " ^ (String.concat " " domains)] else [] in + let nameservers' = List.map (fun ip -> "nameserver " ^ (Unix.string_of_inet_addr ip)) nameservers in + let lines = domains' @ nameservers' in + Xapi_stdext_unix.Unixext.write_string_to_file resolv_conf ((String.concat "\n" lines) ^ "\n") + end else + debug "%s is NOT the DNS interface" name + ) () + + let get_mtu dbg name = + Debug.with_thread_associated dbg (fun () -> + Ip.get_mtu name + ) () + + let set_mtu _ dbg ~name ~mtu = + Debug.with_thread_associated dbg (fun () -> + debug "Configuring MTU for %s: %d" name mtu; + update_config name {(get_config name) with mtu}; + match !backend_kind with + | Openvswitch -> + (try + ignore (Ovs.set_mtu name mtu) + with _ -> + Ip.link_set_mtu name mtu) + | Bridge -> Ip.link_set_mtu name mtu + ) () + + let set_ethtool_settings _ dbg ~name ~params = + Debug.with_thread_associated dbg (fun () -> + debug "Configuring ethtool settings for %s: %s" name + (String.concat ", " (List.map (fun (k, v) -> k ^ "=" ^ v) params)); + let add_defaults = List.filter (fun (k, v) -> not (List.mem_assoc k params)) default_interface.ethtool_settings in + let params = params @ add_defaults in + update_config name {(get_config name) with ethtool_settings = params}; + Ethtool.set_options name params + ) () + + let set_ethtool_offload _ dbg ~name ~params = + Debug.with_thread_associated dbg (fun () -> + debug "Configuring ethtool offload settings for %s: %s" name + (String.concat ", " (List.map (fun (k, v) -> k ^ "=" ^ v) params)); + let add_defaults = List.filter (fun (k, v) -> not (List.mem_assoc k params)) default_interface.ethtool_offload in + let params = params @ add_defaults in + update_config name {(get_config name) with ethtool_offload = params}; + Ethtool.set_offload name params + ) () + + let get_capabilities dbg name = + Debug.with_thread_associated dbg (fun () -> + Fcoe.get_capabilities name @ Sriov.get_capabilities name + ) () + + let is_connected dbg name = + Debug.with_thread_associated dbg (fun () -> + Sysfs.get_carrier name + ) () + + let is_physical dbg name = + Debug.with_thread_associated dbg (fun () -> + Sysfs.is_physical name + ) () + + let has_vlan dbg name vlan = + (* Identify the vlan is used by kernel which is unknown to XAPI *) + Debug.with_thread_associated dbg (fun () -> + List.exists (fun (_, v, p) -> v = vlan && p = name) (Proc.get_vlans ()) + ) () + + let bring_up _ dbg ~name = + Debug.with_thread_associated dbg (fun () -> + debug "Bringing up interface %s" name; + Ip.link_set_up name + ) () + + let bring_down dbg name = + Debug.with_thread_associated dbg (fun () -> + debug "Bringing down interface %s" name; + Ip.link_set_down name + ) () + + let is_persistent _ dbg ~name = + Debug.with_thread_associated dbg (fun () -> + (get_config name).persistent_i + ) () + + let set_persistent dbg name value = + Debug.with_thread_associated dbg (fun () -> + debug "Making interface %s %spersistent" name (if value then "" else "non-"); + update_config name {(get_config name) with persistent_i = value} + ) () + + let make_config dbg conservative config = + Debug.with_thread_associated dbg (fun () -> + (* Only attempt to configure interfaces that exist in the system *) + let all = get_all dbg () in + let config = List.filter (fun (name, _) -> List.mem name all) config in + (* Handle conservativeness *) + let config = + if conservative then begin + (* Do not touch non-persistent interfaces *) + debug "Only configuring persistent interfaces"; + List.filter (fun (name, interface) -> interface.persistent_i) config + end else + config + in + let config = + if need_enic_workaround () then + List.fold_left (fun accu (name, interface) -> + if (Sysfs.is_physical name && Linux_bonding.get_bond_master_of name = None) || Linux_bonding.is_bond_device name then + (name, interface) :: (Ip.vlan_name name 0, interface) :: accu + else + (name, interface) :: accu + ) [] config + else + config + in + debug "** Configuring the following interfaces: %s%s" (String.concat ", " (List.map (fun (name, _) -> name) config)) + (if conservative then " (best effort)" else ""); + let exec f = if conservative then (try f () with _ -> ()) else f () in + List.iter (function (name, ({ipv4_conf; ipv4_gateway; ipv6_conf; ipv6_gateway; ipv4_routes; dns=nameservers,domains; mtu; + ethtool_settings; ethtool_offload; _} as c)) -> + update_config name c; + exec (fun () -> + (* We only apply the DNS settings when in static IPv4 mode to avoid conflicts with DHCP mode. + * The `dns` field should really be an option type so that we don't have to derive the intention + * of the caller by looking at other fields. *) + match ipv4_conf with Static4 _ -> set_dns () dbg ~name ~nameservers ~domains | _ -> ()); + exec (fun () -> set_ipv4_conf dbg name ipv4_conf); + exec (fun () -> match ipv4_gateway with None -> () | Some gateway -> + set_ipv4_gateway () dbg ~name ~address:gateway); + (try set_ipv6_conf () dbg ~name ~conf:ipv6_conf with _ -> ()); + (try match ipv6_gateway with None -> () | Some gateway -> + set_ipv6_gateway () dbg ~name ~address:gateway with _ -> ()); + exec (fun () -> set_ipv4_routes () dbg ~name ~routes:ipv4_routes); + exec (fun () -> set_mtu () dbg ~name ~mtu); + exec (fun () -> bring_up () dbg ~name); + exec (fun () -> set_ethtool_settings () dbg ~name ~params:ethtool_settings); + exec (fun () -> set_ethtool_offload () dbg ~name ~params:ethtool_offload) + ) config + ) () end module Bridge = struct - let add_default = ref [] - - let get_config name = - get_config !config.bridge_config default_bridge name - - let remove_config name = - config := {!config with bridge_config = remove_config !config.bridge_config name} - - let update_config name data = - config := {!config with bridge_config = update_config !config.bridge_config name data} - - let determine_backend () = - try - let backend = String.trim (Xapi_stdext_unix.Unixext.string_of_file !network_conf) in - match backend with - | "openvswitch" | "vswitch" -> backend_kind := Openvswitch - | "bridge" -> backend_kind := Bridge - | backend -> - warn "Network backend unknown (%s). Falling back to Open vSwitch." backend; - backend_kind := Openvswitch - with _ -> - warn "Network-conf file not found. Falling back to Open vSwitch."; - backend_kind := Openvswitch - - let get_bond_links_up _ dbg ~name = - Debug.with_thread_associated dbg (fun () -> - match !backend_kind with - | Openvswitch -> Ovs.get_bond_links_up name - | Bridge -> Proc.get_bond_links_up name - ) () - - let get_all dbg () = - Debug.with_thread_associated dbg (fun () -> - match !backend_kind with - | Openvswitch -> Ovs.list_bridges () - | Bridge -> Sysfs.get_all_bridges () - ) () - - let destroy_existing_vlan_bridge name (parent, vlan) = - begin match !backend_kind with - | Openvswitch -> - let bridges = - let raw = Ovs.vsctl ["--bare"; "-f"; "table"; "--"; "--columns=name"; "find"; "port"; "fake_bridge=true"; "tag=" ^ (string_of_int vlan)] in - if raw <> "" then Astring.String.cuts ~empty:false ~sep:"\n" (String.trim raw) else [] - in - let existing_bridges = - List.filter ( fun bridge -> - match Ovs.bridge_to_vlan bridge with - | Some (p, v) -> p = parent && v = vlan - | None -> false - ) bridges in - List.iter (fun bridge -> - if bridge <> name then begin - debug "Destroying existing bridge %s" bridge; - remove_config bridge; - ignore (Ovs.destroy_bridge bridge) - end - ) existing_bridges - | Bridge -> - let ifaces = Sysfs.bridge_to_interfaces parent in - let existing_bridges = - match List.filter (fun (_, tag, iface) -> tag = vlan && List.mem iface ifaces) (Proc.get_vlans ()) with - | [] -> [] - | (vlan_iface, _, _) :: _ -> - List.filter (fun bridge -> - List.mem vlan_iface (Sysfs.bridge_to_interfaces bridge) - ) (Sysfs.get_all_bridges ()) - in - List.iter (fun bridge -> - if bridge <> name then begin - debug "Destroying existing bridge %s" bridge; - Interface.bring_down "Destroying existing bridge" bridge; - remove_config bridge; - List.iter (fun dev -> - Brctl.destroy_port bridge dev; - ) (Sysfs.bridge_to_interfaces bridge); - ignore (Brctl.destroy_bridge bridge) - end - ) existing_bridges - end - - let create dbg vlan mac igmp_snooping other_config name = - Debug.with_thread_associated dbg (fun () -> - let other_config = match other_config with - | Some l -> l - | None -> [] in - debug "Creating bridge %s%s" name (match vlan with - | None -> "" - | Some (parent, vlan) -> Printf.sprintf " (VLAN %d on bridge %s)" vlan parent - ); - Xapi_stdext_monadic.Opt.iter (destroy_existing_vlan_bridge name) vlan; - update_config name {(get_config name) with vlan; bridge_mac=mac; igmp_snooping; other_config}; - begin match !backend_kind with - | Openvswitch -> - let fail_mode = - if not (List.mem_assoc "vswitch-controller-fail-mode" other_config) then - "standalone" - else - let mode = List.assoc "vswitch-controller-fail-mode" other_config in - if mode = "secure" || mode = "standalone" then begin - (try if mode = "secure" && Ovs.get_fail_mode name <> "secure" then - add_default := name :: !add_default - with _ -> ()); - mode - end else begin - debug "%s isn't a valid setting for other_config:vswitch-controller-fail-mode; \ - defaulting to 'standalone'" mode; - "standalone" - end - in - let vlan_bug_workaround = - if List.mem_assoc "vlan-bug-workaround" other_config then - Some (List.assoc "vlan-bug-workaround" other_config = "true") - else - None - in - let external_id = - if List.mem_assoc "network-uuids" other_config then - Some ("xs-network-uuids", List.assoc "network-uuids" other_config) - else - None - in - let disable_in_band = - if not (List.mem_assoc "vswitch-disable-in-band" other_config) then - Some None - else - let dib = List.assoc "vswitch-disable-in-band" other_config in - if dib = "true" || dib = "false" then - Some (Some dib) - else - (debug "%s isn't a valid setting for other_config:vswitch-disable-in-band" dib; - None) - in - let old_igmp_snooping = Ovs.get_mcast_snooping_enable name in - ignore (Ovs.create_bridge ?mac ~fail_mode ?external_id ?disable_in_band ?igmp_snooping - vlan vlan_bug_workaround name); - if igmp_snooping = Some true && not old_igmp_snooping then - Ovs.inject_igmp_query name - - | Bridge -> - ignore (Brctl.create_bridge name); - Brctl.set_forwarding_delay name 0; - Sysfs.set_multicast_snooping name false; - Xapi_stdext_monadic.Opt.iter (Ip.set_mac name) mac; - match vlan with - | None -> () - | Some (parent, vlan) -> - let bridge_interfaces = Sysfs.bridge_to_interfaces name in - let parent_bridge_interface = List.hd (List.filter (fun n -> - Astring.String.is_prefix ~affix:"eth" n || Astring.String.is_prefix ~affix:"bond" n - ) (Sysfs.bridge_to_interfaces parent)) in - let parent_interface = - if need_enic_workaround () then begin - let n = String.length parent_bridge_interface in - let m = String.sub parent_bridge_interface 0 (n - 2) in - if vlan = 0 then - error "The enic workaround is in effect. Bridge %s is used for VLAN 0 on %s." parent m; - m - end else - parent_bridge_interface - in - let vlan_name = Ip.vlan_name parent_interface vlan in - (* Check if the VLAN is already in use by something else *) - List.iter (fun (device, vlan', parent') -> - (* A device for the same VLAN (parent + tag), but with a different - * device name or not on the requested bridge is bad. *) - if parent' = parent && vlan' = vlan && - (device <> vlan_name || not (List.mem device bridge_interfaces)) then - raise (Vlan_in_use (parent, vlan)) - ) (Proc.get_vlans ()); - (* Robustness enhancement: ensure there are no other VLANs in the bridge *) - let current_interfaces = List.filter (fun n -> - Astring.String.is_prefix ~affix:"eth" n || Astring.String.is_prefix ~affix:"bond" n - ) bridge_interfaces in - debug "Removing these non-VIF interfaces found on the bridge: %s" - (String.concat ", " current_interfaces); - List.iter (fun interface -> - Brctl.destroy_port name interface; - Interface.bring_down dbg interface - ) current_interfaces; - (* Now create the new VLAN device and add it to the bridge *) - Ip.create_vlan parent_interface vlan; - Interface.bring_up () dbg ~name:vlan_name; - Brctl.create_port name vlan_name - end; - Interface.bring_up () dbg ~name - ) () - - let destroy dbg force name = - Debug.with_thread_associated dbg (fun () -> - Interface.bring_down dbg name; - match !backend_kind with - | Openvswitch -> - let vlans_on_this_parent = Ovs.get_vlans name in - if vlans_on_this_parent = [] || force then begin - debug "Destroying bridge %s" name; - remove_config name; - let interfaces = (Ovs.bridge_to_interfaces name) @ vlans_on_this_parent in - List.iter (fun dev -> - Interface.set_ipv4_conf dbg dev None4; - Interface.bring_down dbg dev - ) interfaces; - Interface.set_ipv4_conf dbg name None4; - ignore (Ovs.destroy_bridge name) - end else - debug "Not destroying bridge %s, because it has VLANs on top" name - | Bridge -> - let ifs = Sysfs.bridge_to_interfaces name in - let vlans_on_this_parent = - let interfaces = List.filter (fun n -> - Astring.String.is_prefix ~affix:"eth" n || Astring.String.is_prefix ~affix:"bond" n - ) ifs in - match interfaces with - | [] -> [] - | interface :: _ -> - List.filter (Astring.String.is_prefix ~affix:(interface ^ ".")) (Sysfs.list ()) - in - if vlans_on_this_parent = [] || force then begin - debug "Destroying bridge %s" name; - remove_config name; - List.iter (fun dev -> - Interface.set_ipv4_conf dbg dev None4; - Brctl.destroy_port name dev; - Interface.bring_down dbg dev; - if Linux_bonding.is_bond_device dev then - Linux_bonding.remove_bond_master dev; - if (Astring.String.is_prefix ~affix:"eth" dev || Astring.String.is_prefix ~affix:"bond" dev) && String.contains dev '.' then begin - ignore (Ip.destroy_vlan dev); - let n = String.length dev in - if String.sub dev (n - 2) 2 = ".0" && need_enic_workaround () then - let vlan_base = String.sub dev 0 (n - 2) in - if Linux_bonding.is_bond_device vlan_base then - Linux_bonding.remove_bond_master (String.sub dev 0 (n - 2)) - end; - ) ifs; - Interface.set_ipv4_conf dbg name None4; - ignore (Brctl.destroy_bridge name) - end else - debug "Not destroying bridge %s, because it has VLANs on top" name - ) () - - let get_kind dbg () = - Debug.with_thread_associated dbg (fun () -> - !backend_kind - ) () - - let get_ports _ dbg ~name = - Debug.with_thread_associated dbg (fun () -> - match !backend_kind with - | Openvswitch -> Ovs.bridge_to_ports name - | Bridge -> raise Not_implemented - ) () - - let get_all_ports dbg from_cache = - Debug.with_thread_associated dbg (fun () -> - if from_cache then - let ports = List.concat (List.map (fun (_, {ports}) -> ports) !config.bridge_config) in - List.map (fun (port, {interfaces}) -> port, interfaces) ports - else - match !backend_kind with - | Openvswitch -> List.concat (List.map Ovs.bridge_to_ports (Ovs.list_bridges ())) - | Bridge -> raise Not_implemented - ) () - - let get_bonds _ dbg ~name = - Debug.with_thread_associated dbg (fun () -> - match !backend_kind with - | Openvswitch -> Ovs.bridge_to_ports name - | Bridge -> raise Not_implemented - ) () - - let get_all_bonds dbg from_cache = - Debug.with_thread_associated dbg (fun () -> - if from_cache then - let ports = List.concat (List.map (fun (_, {ports}) -> ports) !config.bridge_config) in - let names = List.map (fun (port, {interfaces}) -> port, interfaces) ports in - List.filter (fun (_, ifs) -> List.length ifs > 1) names - else - match !backend_kind with - | Openvswitch -> List.concat (List.map Ovs.bridge_to_ports (Ovs.list_bridges ())) - | Bridge -> raise Not_implemented - ) () - - type bond_link_info = { - slave: iface; - up: bool; - active: bool; - } - - let get_bond_link_info _ dbg ~name = - Debug.with_thread_associated dbg (fun () -> - match !backend_kind with - | Openvswitch -> - let slaves, active_slave = Ovs.get_bond_link_status name in - let mode = Ovs.get_bond_mode name in - List.map (fun (slave, up) -> - let active = - let ab = mode = Some "active-backup" in - ab && (active_slave = Some slave) || - (not ab) && up - in - {slave; up; active} - ) slaves - | Bridge -> - let active_slave = Linux_bonding.get_bond_active_slave name in - let slaves = Proc.get_bond_slave_info name "MII Status" in - let bond_props = Linux_bonding.get_bond_properties name in - List.map (fun (slave, status) -> - let up = status = "up" in - let active = - let ab = - List.mem_assoc "mode" bond_props && - Astring.String.is_prefix ~affix:"active-backup" (List.assoc "mode" bond_props) - in - ab && (active_slave = Some slave) || - (not ab) && up - in - {slave; up; active} - ) slaves - ) () - - let get_vlan _ dbg ~name = - Debug.with_thread_associated dbg (fun () -> - match !backend_kind with - | Openvswitch -> Ovs.bridge_to_vlan name - | Bridge -> raise Not_implemented - ) () - - let add_default_flows _ dbg bridge mac interfaces = - Debug.with_thread_associated dbg (fun () -> - match !backend_kind with - | Openvswitch -> Ovs.add_default_flows bridge mac interfaces - | Bridge -> () - ) () - - let add_basic_port dbg bridge name {interfaces; bond_mac; bond_properties} = - match !backend_kind with - | Openvswitch -> - if List.length interfaces = 1 then begin - List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces; - ignore (Ovs.create_port (List.hd interfaces) bridge) - end else begin - if bond_mac = None then - warn "No MAC address specified for the bond"; - ignore (Ovs.create_bond ?mac:bond_mac name interfaces bridge bond_properties); - List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces - end; - if List.mem bridge !add_default then begin - let mac = match bond_mac with - | None -> (try Some (Ip.get_mac name) with _ -> None) - | Some mac -> Some mac - in - match mac with - | Some mac -> - add_default_flows () dbg bridge mac interfaces; - add_default := List.filter ((<>) bridge) !add_default - | None -> - warn "Could not add default flows for port %s on bridge %s because no MAC address was specified" - name bridge - end - | Bridge -> - if List.length interfaces = 1 then - List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces - else begin - Linux_bonding.add_bond_master name; - let bond_properties = - if List.mem_assoc "mode" bond_properties && List.assoc "mode" bond_properties = "lacp" then - Xapi_stdext_std.Listext.List.replace_assoc "mode" "802.3ad" bond_properties - else bond_properties - in - Linux_bonding.set_bond_properties name bond_properties; - Linux_bonding.set_bond_slaves name interfaces; - begin match bond_mac with - | Some mac -> Ip.set_mac name mac - | None -> warn "No MAC address specified for the bond" - end; - Interface.bring_up () dbg ~name - end; - if need_enic_workaround () then begin - debug "Applying enic workaround: adding VLAN0 device to bridge"; - Ip.create_vlan name 0; - let vlan0 = Ip.vlan_name name 0 in - Interface.bring_up () dbg ~name:vlan0; - ignore (Brctl.create_port bridge vlan0) - end else - ignore (Brctl.create_port bridge name) - - let add_pvs_proxy_port dbg bridge name port = - match !backend_kind with - | Openvswitch -> - ignore (Ovs.create_port ~internal:true name bridge); - let real_bridge = Ovs.get_real_bridge bridge in - Ovs.mod_port real_bridge name "no-flood"; - Interface.bring_up () dbg ~name - | Bridge -> - raise Not_implemented - - let add_port dbg bond_mac bridge name interfaces bond_properties kind = - Debug.with_thread_associated dbg (fun () -> - let bond_properties = match bond_properties with - | Some l -> l - | None -> [] - in - let kind = match kind with - | Some v -> v - | None -> Basic_port - in - let config = get_config bridge in - let ports = - if List.mem_assoc name config.ports then - List.remove_assoc name config.ports - else - config.ports - in - let port = {interfaces; bond_mac; bond_properties; kind} in - let ports = (name, port) :: ports in - update_config bridge {config with ports}; - debug "Adding %s port %s to bridge %s with interface(s) %s%s" - (string_of_port_kind kind) - name bridge - (String.concat ", " interfaces) - (match bond_mac with Some mac -> " and MAC " ^ mac | None -> ""); - match kind with - | Basic_port -> add_basic_port dbg bridge name port - | PVS_proxy -> add_pvs_proxy_port dbg bridge name port - ) () - - let remove_port dbg bridge name = - Debug.with_thread_associated dbg (fun () -> - debug "Removing port %s from bridge %s" name bridge; - let config = get_config bridge in - if List.mem_assoc name config.ports then begin - let ports = List.remove_assoc name config.ports in - update_config bridge {config with ports} - end; - match !backend_kind with - | Openvswitch -> - ignore (Ovs.destroy_port name) - | Bridge -> - ignore (Brctl.destroy_port bridge name) - ) () - - let get_interfaces dbg name = - Debug.with_thread_associated dbg (fun () -> - match !backend_kind with - | Openvswitch -> - Ovs.bridge_to_interfaces name - | Bridge -> - Sysfs.bridge_to_interfaces name - ) () - - let get_physical_interfaces dbg name = - Debug.with_thread_associated dbg (fun () -> - match !backend_kind with - | Openvswitch -> - Ovs.get_real_bridge name - |> Ovs.bridge_to_interfaces - |> List.filter (Sysfs.is_physical) - - | Bridge -> - let ifaces = Sysfs.bridge_to_interfaces name in - let vlan_ifaces = List.filter (fun (bridge, _, _) -> List.mem bridge ifaces) (Proc.get_vlans ()) in - let bond_ifaces = List.filter (fun iface -> Linux_bonding.is_bond_device iface) ifaces in - let physical_ifaces = List.filter (fun iface -> Sysfs.is_physical iface) ifaces in - if vlan_ifaces <> [] then - let _, _, parent = List.hd vlan_ifaces in - if Linux_bonding.is_bond_device parent then - Linux_bonding.get_bond_slaves parent - else - [parent] - else if bond_ifaces <> [] then - Linux_bonding.get_bond_slaves (List.hd bond_ifaces) - else - physical_ifaces - ) () - - let get_fail_mode _ dbg ~name = - Debug.with_thread_associated dbg (fun () -> - match !backend_kind with - | Openvswitch -> - begin match Ovs.get_fail_mode name with - | "standalone" -> Some Standalone - | "secure" -> Some Secure - | _ -> None - end - | Bridge -> raise Not_implemented - ) () - - let is_persistent _ dbg ~name = - Debug.with_thread_associated dbg (fun () -> - (get_config name).persistent_b - ) () - - let set_persistent dbg name value = - Debug.with_thread_associated dbg (fun () -> - debug "Making bridge %s %spersistent" name (if value then "" else "non-"); - update_config name {(get_config name) with persistent_b = value} - ) () - - let make_config dbg conservative config = - Debug.with_thread_associated dbg (fun () -> - let vlans_go_last (_, {vlan=vlan_of_a}) (_, {vlan=vlan_of_b}) = - if vlan_of_a = None && vlan_of_b = None then 0 - else if vlan_of_a <> None && vlan_of_b = None then 1 - else if vlan_of_a = None && vlan_of_b <> None then -1 - else 0 - in - let config = - if conservative then begin - let persistent_config = List.filter (fun (name, bridge) -> bridge.persistent_b) config in - debug "Ensuring the following persistent bridges are up: %s" - (String.concat ", " (List.map (fun (name, _) -> name) persistent_config)); - let vlan_parents = Xapi_stdext_std.Listext.List.filter_map (function - | (_, {vlan=Some (parent, _)}) -> - if not (List.mem_assoc parent persistent_config) then - Some (parent, List.assoc parent config) - else - None - | _ -> None) persistent_config in - debug "Additionally ensuring the following VLAN parent bridges are up: %s" - (String.concat ", " (List.map (fun (name, _) -> name) vlan_parents)); - let config = vlan_parents @ persistent_config in - (* Do not try to recreate bridges that already exist *) - let current = get_all dbg () in - List.filter (function (name, _) -> not (List.mem name current)) config - end else - config - in - let config = List.sort vlans_go_last config in - let exec f = if conservative then (try f () with _ -> ()) else f () in - debug "** Configuring the following bridges: %s%s" - (String.concat ", " (List.map (fun (name, _) -> name) config)) - (if conservative then " (best effort)" else ""); - List.iter (function (bridge_name, ({ports; vlan; bridge_mac; igmp_snooping; other_config; _} as c)) -> - update_config bridge_name c; - exec (fun () -> - create dbg vlan bridge_mac igmp_snooping (Some other_config) bridge_name; - List.iter (fun (port_name, {interfaces; bond_properties; bond_mac; kind}) -> - add_port dbg bond_mac bridge_name port_name interfaces (Some bond_properties) (Some kind)) ports - ) - ) config - ) () + let add_default = ref [] + + let get_config name = + get_config !config.bridge_config default_bridge name + + let remove_config name = + config := {!config with bridge_config = remove_config !config.bridge_config name} + + let update_config name data = + config := {!config with bridge_config = update_config !config.bridge_config name data} + + let determine_backend () = + try + let backend = String.trim (Xapi_stdext_unix.Unixext.string_of_file !network_conf) in + match backend with + | "openvswitch" | "vswitch" -> backend_kind := Openvswitch + | "bridge" -> backend_kind := Bridge + | backend -> + warn "Network backend unknown (%s). Falling back to Open vSwitch." backend; + backend_kind := Openvswitch + with _ -> + warn "Network-conf file not found. Falling back to Open vSwitch."; + backend_kind := Openvswitch + + let get_bond_links_up _ dbg ~name = + Debug.with_thread_associated dbg (fun () -> + match !backend_kind with + | Openvswitch -> Ovs.get_bond_links_up name + | Bridge -> Proc.get_bond_links_up name + ) () + + let get_all dbg () = + Debug.with_thread_associated dbg (fun () -> + match !backend_kind with + | Openvswitch -> Ovs.list_bridges () + | Bridge -> Sysfs.get_all_bridges () + ) () + + let destroy_existing_vlan_bridge name (parent, vlan) = + begin match !backend_kind with + | Openvswitch -> + let bridges = + let raw = Ovs.vsctl ["--bare"; "-f"; "table"; "--"; "--columns=name"; "find"; "port"; "fake_bridge=true"; "tag=" ^ (string_of_int vlan)] in + if raw <> "" then Astring.String.cuts ~empty:false ~sep:"\n" (String.trim raw) else [] + in + let existing_bridges = + List.filter ( fun bridge -> + match Ovs.bridge_to_vlan bridge with + | Some (p, v) -> p = parent && v = vlan + | None -> false + ) bridges in + List.iter (fun bridge -> + if bridge <> name then begin + debug "Destroying existing bridge %s" bridge; + remove_config bridge; + ignore (Ovs.destroy_bridge bridge) + end + ) existing_bridges + | Bridge -> + let ifaces = Sysfs.bridge_to_interfaces parent in + let existing_bridges = + match List.filter (fun (_, tag, iface) -> tag = vlan && List.mem iface ifaces) (Proc.get_vlans ()) with + | [] -> [] + | (vlan_iface, _, _) :: _ -> + List.filter (fun bridge -> + List.mem vlan_iface (Sysfs.bridge_to_interfaces bridge) + ) (Sysfs.get_all_bridges ()) + in + List.iter (fun bridge -> + if bridge <> name then begin + debug "Destroying existing bridge %s" bridge; + Interface.bring_down "Destroying existing bridge" bridge; + remove_config bridge; + List.iter (fun dev -> + Brctl.destroy_port bridge dev; + ) (Sysfs.bridge_to_interfaces bridge); + ignore (Brctl.destroy_bridge bridge) + end + ) existing_bridges + end + + let create dbg vlan mac igmp_snooping other_config name = + Debug.with_thread_associated dbg (fun () -> + let other_config = match other_config with + | Some l -> l + | None -> [] in + debug "Creating bridge %s%s" name (match vlan with + | None -> "" + | Some (parent, vlan) -> Printf.sprintf " (VLAN %d on bridge %s)" vlan parent + ); + Xapi_stdext_monadic.Opt.iter (destroy_existing_vlan_bridge name) vlan; + update_config name {(get_config name) with vlan; bridge_mac=mac; igmp_snooping; other_config}; + begin match !backend_kind with + | Openvswitch -> + let fail_mode = + if not (List.mem_assoc "vswitch-controller-fail-mode" other_config) then + "standalone" + else + let mode = List.assoc "vswitch-controller-fail-mode" other_config in + if mode = "secure" || mode = "standalone" then begin + (try if mode = "secure" && Ovs.get_fail_mode name <> "secure" then + add_default := name :: !add_default + with _ -> ()); + mode + end else begin + debug "%s isn't a valid setting for other_config:vswitch-controller-fail-mode; \ + defaulting to 'standalone'" mode; + "standalone" + end + in + let vlan_bug_workaround = + if List.mem_assoc "vlan-bug-workaround" other_config then + Some (List.assoc "vlan-bug-workaround" other_config = "true") + else + None + in + let external_id = + if List.mem_assoc "network-uuids" other_config then + Some ("xs-network-uuids", List.assoc "network-uuids" other_config) + else + None + in + let disable_in_band = + if not (List.mem_assoc "vswitch-disable-in-band" other_config) then + Some None + else + let dib = List.assoc "vswitch-disable-in-band" other_config in + if dib = "true" || dib = "false" then + Some (Some dib) + else + (debug "%s isn't a valid setting for other_config:vswitch-disable-in-band" dib; + None) + in + let old_igmp_snooping = Ovs.get_mcast_snooping_enable name in + ignore (Ovs.create_bridge ?mac ~fail_mode ?external_id ?disable_in_band ?igmp_snooping + vlan vlan_bug_workaround name); + if igmp_snooping = Some true && not old_igmp_snooping then + Ovs.inject_igmp_query name + + | Bridge -> + ignore (Brctl.create_bridge name); + Brctl.set_forwarding_delay name 0; + Sysfs.set_multicast_snooping name false; + Xapi_stdext_monadic.Opt.iter (Ip.set_mac name) mac; + match vlan with + | None -> () + | Some (parent, vlan) -> + let bridge_interfaces = Sysfs.bridge_to_interfaces name in + let parent_bridge_interface = List.hd (List.filter (fun n -> + Astring.String.is_prefix ~affix:"eth" n || Astring.String.is_prefix ~affix:"bond" n + ) (Sysfs.bridge_to_interfaces parent)) in + let parent_interface = + if need_enic_workaround () then begin + let n = String.length parent_bridge_interface in + let m = String.sub parent_bridge_interface 0 (n - 2) in + if vlan = 0 then + error "The enic workaround is in effect. Bridge %s is used for VLAN 0 on %s." parent m; + m + end else + parent_bridge_interface + in + let vlan_name = Ip.vlan_name parent_interface vlan in + (* Check if the VLAN is already in use by something else *) + List.iter (fun (device, vlan', parent') -> + (* A device for the same VLAN (parent + tag), but with a different + * device name or not on the requested bridge is bad. *) + if parent' = parent && vlan' = vlan && + (device <> vlan_name || not (List.mem device bridge_interfaces)) then + raise (Vlan_in_use (parent, vlan)) + ) (Proc.get_vlans ()); + (* Robustness enhancement: ensure there are no other VLANs in the bridge *) + let current_interfaces = List.filter (fun n -> + Astring.String.is_prefix ~affix:"eth" n || Astring.String.is_prefix ~affix:"bond" n + ) bridge_interfaces in + debug "Removing these non-VIF interfaces found on the bridge: %s" + (String.concat ", " current_interfaces); + List.iter (fun interface -> + Brctl.destroy_port name interface; + Interface.bring_down dbg interface + ) current_interfaces; + (* Now create the new VLAN device and add it to the bridge *) + Ip.create_vlan parent_interface vlan; + Interface.bring_up () dbg ~name:vlan_name; + Brctl.create_port name vlan_name + end; + Interface.bring_up () dbg ~name + ) () + + let destroy dbg force name = + Debug.with_thread_associated dbg (fun () -> + Interface.bring_down dbg name; + match !backend_kind with + | Openvswitch -> + let vlans_on_this_parent = Ovs.get_vlans name in + if vlans_on_this_parent = [] || force then begin + debug "Destroying bridge %s" name; + remove_config name; + let interfaces = (Ovs.bridge_to_interfaces name) @ vlans_on_this_parent in + List.iter (fun dev -> + Interface.set_ipv4_conf dbg dev None4; + Interface.bring_down dbg dev + ) interfaces; + Interface.set_ipv4_conf dbg name None4; + ignore (Ovs.destroy_bridge name) + end else + debug "Not destroying bridge %s, because it has VLANs on top" name + | Bridge -> + let ifs = Sysfs.bridge_to_interfaces name in + let vlans_on_this_parent = + let interfaces = List.filter (fun n -> + Astring.String.is_prefix ~affix:"eth" n || Astring.String.is_prefix ~affix:"bond" n + ) ifs in + match interfaces with + | [] -> [] + | interface :: _ -> + List.filter (Astring.String.is_prefix ~affix:(interface ^ ".")) (Sysfs.list ()) + in + if vlans_on_this_parent = [] || force then begin + debug "Destroying bridge %s" name; + remove_config name; + List.iter (fun dev -> + Interface.set_ipv4_conf dbg dev None4; + Brctl.destroy_port name dev; + Interface.bring_down dbg dev; + if Linux_bonding.is_bond_device dev then + Linux_bonding.remove_bond_master dev; + if (Astring.String.is_prefix ~affix:"eth" dev || Astring.String.is_prefix ~affix:"bond" dev) && String.contains dev '.' then begin + ignore (Ip.destroy_vlan dev); + let n = String.length dev in + if String.sub dev (n - 2) 2 = ".0" && need_enic_workaround () then + let vlan_base = String.sub dev 0 (n - 2) in + if Linux_bonding.is_bond_device vlan_base then + Linux_bonding.remove_bond_master (String.sub dev 0 (n - 2)) + end; + ) ifs; + Interface.set_ipv4_conf dbg name None4; + ignore (Brctl.destroy_bridge name) + end else + debug "Not destroying bridge %s, because it has VLANs on top" name + ) () + + let get_kind dbg () = + Debug.with_thread_associated dbg (fun () -> + !backend_kind + ) () + + let get_ports _ dbg ~name = + Debug.with_thread_associated dbg (fun () -> + match !backend_kind with + | Openvswitch -> Ovs.bridge_to_ports name + | Bridge -> raise Not_implemented + ) () + + let get_all_ports dbg from_cache = + Debug.with_thread_associated dbg (fun () -> + if from_cache then + let ports = List.concat (List.map (fun (_, {ports}) -> ports) !config.bridge_config) in + List.map (fun (port, {interfaces}) -> port, interfaces) ports + else + match !backend_kind with + | Openvswitch -> List.concat (List.map Ovs.bridge_to_ports (Ovs.list_bridges ())) + | Bridge -> raise Not_implemented + ) () + + let get_bonds _ dbg ~name = + Debug.with_thread_associated dbg (fun () -> + match !backend_kind with + | Openvswitch -> Ovs.bridge_to_ports name + | Bridge -> raise Not_implemented + ) () + + let get_all_bonds dbg from_cache = + Debug.with_thread_associated dbg (fun () -> + if from_cache then + let ports = List.concat (List.map (fun (_, {ports}) -> ports) !config.bridge_config) in + let names = List.map (fun (port, {interfaces}) -> port, interfaces) ports in + List.filter (fun (_, ifs) -> List.length ifs > 1) names + else + match !backend_kind with + | Openvswitch -> List.concat (List.map Ovs.bridge_to_ports (Ovs.list_bridges ())) + | Bridge -> raise Not_implemented + ) () + + type bond_link_info = { + slave: iface; + up: bool; + active: bool; + } + + let get_bond_link_info _ dbg ~name = + Debug.with_thread_associated dbg (fun () -> + match !backend_kind with + | Openvswitch -> + let slaves, active_slave = Ovs.get_bond_link_status name in + let mode = Ovs.get_bond_mode name in + List.map (fun (slave, up) -> + let active = + let ab = mode = Some "active-backup" in + ab && (active_slave = Some slave) || + (not ab) && up + in + {slave; up; active} + ) slaves + | Bridge -> + let active_slave = Linux_bonding.get_bond_active_slave name in + let slaves = Proc.get_bond_slave_info name "MII Status" in + let bond_props = Linux_bonding.get_bond_properties name in + List.map (fun (slave, status) -> + let up = status = "up" in + let active = + let ab = + List.mem_assoc "mode" bond_props && + Astring.String.is_prefix ~affix:"active-backup" (List.assoc "mode" bond_props) + in + ab && (active_slave = Some slave) || + (not ab) && up + in + {slave; up; active} + ) slaves + ) () + + let get_vlan _ dbg ~name = + Debug.with_thread_associated dbg (fun () -> + match !backend_kind with + | Openvswitch -> Ovs.bridge_to_vlan name + | Bridge -> raise Not_implemented + ) () + + let add_default_flows _ dbg bridge mac interfaces = + Debug.with_thread_associated dbg (fun () -> + match !backend_kind with + | Openvswitch -> Ovs.add_default_flows bridge mac interfaces + | Bridge -> () + ) () + + let add_basic_port dbg bridge name {interfaces; bond_mac; bond_properties} = + match !backend_kind with + | Openvswitch -> + if List.length interfaces = 1 then begin + List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces; + ignore (Ovs.create_port (List.hd interfaces) bridge) + end else begin + if bond_mac = None then + warn "No MAC address specified for the bond"; + ignore (Ovs.create_bond ?mac:bond_mac name interfaces bridge bond_properties); + List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces + end; + if List.mem bridge !add_default then begin + let mac = match bond_mac with + | None -> (try Some (Ip.get_mac name) with _ -> None) + | Some mac -> Some mac + in + match mac with + | Some mac -> + add_default_flows () dbg bridge mac interfaces; + add_default := List.filter ((<>) bridge) !add_default + | None -> + warn "Could not add default flows for port %s on bridge %s because no MAC address was specified" + name bridge + end + | Bridge -> + if List.length interfaces = 1 then + List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces + else begin + Linux_bonding.add_bond_master name; + let bond_properties = + if List.mem_assoc "mode" bond_properties && List.assoc "mode" bond_properties = "lacp" then + Xapi_stdext_std.Listext.List.replace_assoc "mode" "802.3ad" bond_properties + else bond_properties + in + Linux_bonding.set_bond_properties name bond_properties; + Linux_bonding.set_bond_slaves name interfaces; + begin match bond_mac with + | Some mac -> Ip.set_mac name mac + | None -> warn "No MAC address specified for the bond" + end; + Interface.bring_up () dbg ~name + end; + if need_enic_workaround () then begin + debug "Applying enic workaround: adding VLAN0 device to bridge"; + Ip.create_vlan name 0; + let vlan0 = Ip.vlan_name name 0 in + Interface.bring_up () dbg ~name:vlan0; + ignore (Brctl.create_port bridge vlan0) + end else + ignore (Brctl.create_port bridge name) + + let add_pvs_proxy_port dbg bridge name port = + match !backend_kind with + | Openvswitch -> + ignore (Ovs.create_port ~internal:true name bridge); + let real_bridge = Ovs.get_real_bridge bridge in + Ovs.mod_port real_bridge name "no-flood"; + Interface.bring_up () dbg ~name + | Bridge -> + raise Not_implemented + + let add_port dbg bond_mac bridge name interfaces bond_properties kind = + Debug.with_thread_associated dbg (fun () -> + let bond_properties = match bond_properties with + | Some l -> l + | None -> [] + in + let kind = match kind with + | Some v -> v + | None -> Basic_port + in + let config = get_config bridge in + let ports = + if List.mem_assoc name config.ports then + List.remove_assoc name config.ports + else + config.ports + in + let port = {interfaces; bond_mac; bond_properties; kind} in + let ports = (name, port) :: ports in + update_config bridge {config with ports}; + debug "Adding %s port %s to bridge %s with interface(s) %s%s" + (string_of_port_kind kind) + name bridge + (String.concat ", " interfaces) + (match bond_mac with Some mac -> " and MAC " ^ mac | None -> ""); + match kind with + | Basic_port -> add_basic_port dbg bridge name port + | PVS_proxy -> add_pvs_proxy_port dbg bridge name port + ) () + + let remove_port dbg bridge name = + Debug.with_thread_associated dbg (fun () -> + debug "Removing port %s from bridge %s" name bridge; + let config = get_config bridge in + if List.mem_assoc name config.ports then begin + let ports = List.remove_assoc name config.ports in + update_config bridge {config with ports} + end; + match !backend_kind with + | Openvswitch -> + ignore (Ovs.destroy_port name) + | Bridge -> + ignore (Brctl.destroy_port bridge name) + ) () + + let get_interfaces dbg name = + Debug.with_thread_associated dbg (fun () -> + match !backend_kind with + | Openvswitch -> + Ovs.bridge_to_interfaces name + | Bridge -> + Sysfs.bridge_to_interfaces name + ) () + + let get_physical_interfaces dbg name = + Debug.with_thread_associated dbg (fun () -> + match !backend_kind with + | Openvswitch -> + Ovs.get_real_bridge name + |> Ovs.bridge_to_interfaces + |> List.filter (Sysfs.is_physical) + + | Bridge -> + let ifaces = Sysfs.bridge_to_interfaces name in + let vlan_ifaces = List.filter (fun (bridge, _, _) -> List.mem bridge ifaces) (Proc.get_vlans ()) in + let bond_ifaces = List.filter (fun iface -> Linux_bonding.is_bond_device iface) ifaces in + let physical_ifaces = List.filter (fun iface -> Sysfs.is_physical iface) ifaces in + if vlan_ifaces <> [] then + let _, _, parent = List.hd vlan_ifaces in + if Linux_bonding.is_bond_device parent then + Linux_bonding.get_bond_slaves parent + else + [parent] + else if bond_ifaces <> [] then + Linux_bonding.get_bond_slaves (List.hd bond_ifaces) + else + physical_ifaces + ) () + + let get_fail_mode _ dbg ~name = + Debug.with_thread_associated dbg (fun () -> + match !backend_kind with + | Openvswitch -> + begin match Ovs.get_fail_mode name with + | "standalone" -> Some Standalone + | "secure" -> Some Secure + | _ -> None + end + | Bridge -> raise Not_implemented + ) () + + let is_persistent _ dbg ~name = + Debug.with_thread_associated dbg (fun () -> + (get_config name).persistent_b + ) () + + let set_persistent dbg name value = + Debug.with_thread_associated dbg (fun () -> + debug "Making bridge %s %spersistent" name (if value then "" else "non-"); + update_config name {(get_config name) with persistent_b = value} + ) () + + let make_config dbg conservative config = + Debug.with_thread_associated dbg (fun () -> + let vlans_go_last (_, {vlan=vlan_of_a}) (_, {vlan=vlan_of_b}) = + if vlan_of_a = None && vlan_of_b = None then 0 + else if vlan_of_a <> None && vlan_of_b = None then 1 + else if vlan_of_a = None && vlan_of_b <> None then -1 + else 0 + in + let config = + if conservative then begin + let persistent_config = List.filter (fun (name, bridge) -> bridge.persistent_b) config in + debug "Ensuring the following persistent bridges are up: %s" + (String.concat ", " (List.map (fun (name, _) -> name) persistent_config)); + let vlan_parents = Xapi_stdext_std.Listext.List.filter_map (function + | (_, {vlan=Some (parent, _)}) -> + if not (List.mem_assoc parent persistent_config) then + Some (parent, List.assoc parent config) + else + None + | _ -> None) persistent_config in + debug "Additionally ensuring the following VLAN parent bridges are up: %s" + (String.concat ", " (List.map (fun (name, _) -> name) vlan_parents)); + let config = vlan_parents @ persistent_config in + (* Do not try to recreate bridges that already exist *) + let current = get_all dbg () in + List.filter (function (name, _) -> not (List.mem name current)) config + end else + config + in + let config = List.sort vlans_go_last config in + let exec f = if conservative then (try f () with _ -> ()) else f () in + debug "** Configuring the following bridges: %s%s" + (String.concat ", " (List.map (fun (name, _) -> name) config)) + (if conservative then " (best effort)" else ""); + List.iter (function (bridge_name, ({ports; vlan; bridge_mac; igmp_snooping; other_config; _} as c)) -> + update_config bridge_name c; + exec (fun () -> + create dbg vlan bridge_mac igmp_snooping (Some other_config) bridge_name; + List.iter (fun (port_name, {interfaces; bond_properties; bond_mac; kind}) -> + add_port dbg bond_mac bridge_name port_name interfaces (Some bond_properties) (Some kind)) ports + ) + ) config + ) () end module PVS_proxy = struct - open S.PVS_proxy - - let path = ref "/opt/citrix/pvsproxy/socket/pvsproxy" - - let do_call call = - try - Jsonrpc_client.with_rpc ~path:!path ~call () - with e -> - error "Error when calling PVS proxy: %s" (Printexc.to_string e); - raise PVS_proxy_connection_error - - let configure_site dbg config = - debug "Configuring PVS proxy for site %s" config.site_uuid; - let call = {Rpc.name = "configure_site"; params = [Rpcmarshal.marshal t.ty config]} in - let _ = do_call call in - () - - let remove_site dbg uuid = - debug "Removing PVS proxy for site %s" uuid; - let call = Rpc.{name = "remove_site"; params = [Dict ["site_uuid", Rpcmarshal.marshal Rpc.Types.string.ty uuid]]} in - let _ = do_call call in - () + open S.PVS_proxy + + let path = ref "/opt/citrix/pvsproxy/socket/pvsproxy" + + let do_call call = + try + Jsonrpc_client.with_rpc ~path:!path ~call () + with e -> + error "Error when calling PVS proxy: %s" (Printexc.to_string e); + raise PVS_proxy_connection_error + + let configure_site dbg config = + debug "Configuring PVS proxy for site %s" config.site_uuid; + let call = {Rpc.name = "configure_site"; params = [Rpcmarshal.marshal t.ty config]} in + let _ = do_call call in + () + + let remove_site dbg uuid = + debug "Removing PVS proxy for site %s" uuid; + let call = Rpc.{name = "remove_site"; params = [Dict ["site_uuid", Rpcmarshal.marshal Rpc.Types.string.ty uuid]]} in + let _ = do_call call in + () end let on_startup () = - let dbg = "startup" in - Debug.with_thread_associated dbg (fun () -> - Bridge.determine_backend (); - let remove_centos_config () = - (* Remove DNSDEV and GATEWAYDEV from Centos networking file, because the interfere - * with this daemon. *) - try - let file = String.trim (Xapi_stdext_unix.Unixext.string_of_file "/etc/sysconfig/network") in - let args = Astring.String.cuts ~empty:false ~sep:"\n" file in - let args = List.map (fun s -> match (Astring.String.cuts ~sep:"=" s) with k :: [v] -> k, v | _ -> "", "") args in - let args = List.filter (fun (k, v) -> k <> "DNSDEV" && k <> "GATEWAYDEV") args in - let s = String.concat "\n" (List.map (fun (k, v) -> k ^ "=" ^ v) args) ^ "\n" in - Xapi_stdext_unix.Unixext.write_string_to_file "/etc/sysconfig/network" s - with _ -> () - in - try - (* the following is best-effort *) - read_config (); - remove_centos_config (); - if !backend_kind = Openvswitch then - Ovs.set_max_idle 5000; - Bridge.make_config dbg true !config.bridge_config; - Interface.make_config dbg true !config.interface_config; - (* If there is still a network.dbcache file, move it out of the way. *) - if (try Unix.access (Filename.concat "/var/lib/xcp" "network.dbcache") [Unix.F_OK]; true with _ -> false) then - Unix.rename (Filename.concat "/var/lib/xcp" "network.dbcache") (Filename.concat "/var/lib/xcp" "network.dbcache.bak"); - with e -> - debug "Error while configuring networks on startup: %s\n%s" - (Printexc.to_string e) (Printexc.get_backtrace ()) - ) () + let dbg = "startup" in + Debug.with_thread_associated dbg (fun () -> + Bridge.determine_backend (); + let remove_centos_config () = + (* Remove DNSDEV and GATEWAYDEV from Centos networking file, because the interfere + * with this daemon. *) + try + let file = String.trim (Xapi_stdext_unix.Unixext.string_of_file "/etc/sysconfig/network") in + let args = Astring.String.cuts ~empty:false ~sep:"\n" file in + let args = List.map (fun s -> match (Astring.String.cuts ~sep:"=" s) with k :: [v] -> k, v | _ -> "", "") args in + let args = List.filter (fun (k, v) -> k <> "DNSDEV" && k <> "GATEWAYDEV") args in + let s = String.concat "\n" (List.map (fun (k, v) -> k ^ "=" ^ v) args) ^ "\n" in + Xapi_stdext_unix.Unixext.write_string_to_file "/etc/sysconfig/network" s + with _ -> () + in + try + (* the following is best-effort *) + read_config (); + remove_centos_config (); + if !backend_kind = Openvswitch then + Ovs.set_max_idle 5000; + Bridge.make_config dbg true !config.bridge_config; + Interface.make_config dbg true !config.interface_config; + (* If there is still a network.dbcache file, move it out of the way. *) + if (try Unix.access (Filename.concat "/var/lib/xcp" "network.dbcache") [Unix.F_OK]; true with _ -> false) then + Unix.rename (Filename.concat "/var/lib/xcp" "network.dbcache") (Filename.concat "/var/lib/xcp" "network.dbcache.bak"); + with e -> + debug "Error while configuring networks on startup: %s\n%s" + (Printexc.to_string e) (Printexc.get_backtrace ()) + ) () diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 4b2f90068..2eae91794 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -53,45 +53,45 @@ let resources = [ ] let options = [ - "monitor_whitelist", Arg.String (fun x -> Network_monitor_thread.monitor_whitelist := Astring.String.cuts ~empty:false ~sep:"," x), (fun () -> String.concat "," !Network_monitor_thread.monitor_whitelist), "List of prefixes of interface names that are to be monitored"; - "mac-table-size", Arg.Set_int Network_utils.mac_table_size, (fun () -> string_of_int !Network_utils.mac_table_size), "Default value for the mac-table-size openvswitch parameter (see ovs-vswitchd.conf.db.5)"; - "enic-workaround-until-version", Arg.Set_string Network_server.enic_workaround_until_version, (fun () -> !Network_server.enic_workaround_until_version), "The version till enic driver workaround will be applied or the version set to an empty string for not applying the workaround."; - "pvs-proxy-socket", Arg.Set_string Network_server.PVS_proxy.path, (fun () -> !Network_server.PVS_proxy.path), "Path to the Unix domain socket for the PVS-proxy daemon"; - "igmp-query-maxresp-time", Arg.Set_string Network_utils.igmp_query_maxresp_time, (fun () -> !Network_utils.igmp_query_maxresp_time), "Maximum Response Time in IGMP Query message to send"; - "enable-ipv6-mcast-snooping", Arg.Bool (fun x -> Network_utils.enable_ipv6_mcast_snooping := x), (fun () -> string_of_bool !Network_utils.enable_ipv6_mcast_snooping), "IPv6 multicast snooping toggle"; - "mcast-snooping-disable-flood-unregistered", Arg.Bool (fun x -> Network_utils.mcast_snooping_disable_flood_unregistered := x), (fun () -> string_of_bool !Network_utils.mcast_snooping_disable_flood_unregistered), "Set OVS bridge configuration mcast-snooping-disable-flood-unregistered as 'true' or 'false'"; - "uname-cmd-path", Arg.Set_string Network_utils.uname, (fun () -> !Network_utils.uname), "Path to the Unix command uname"; - "dracut-cmd-path", Arg.Set_string Network_utils.dracut, (fun () -> !Network_utils.dracut), "Path to the Unix command dracut"; - "dracut-timeout", Arg.Set_float Network_utils.dracut_timeout, (fun () -> string_of_float !Network_utils.dracut_timeout), "Default value for the dracut command timeout"; - "modinfo-cmd-path", Arg.Set_string Network_utils.modinfo, (fun () -> !Network_utils.modinfo), "Path to the Unix command modinfo"; - "json-rpc-max-len", Arg.Set_int Jsonrpc_client.json_rpc_max_len, (fun () -> string_of_int !Jsonrpc_client.json_rpc_max_len), "Maximum buffer size for Json RPC response"; - "json-rpc-read-timeout", Arg.Int (fun x -> Jsonrpc_client.json_rpc_read_timeout := Int64.(mul 1000000L (of_int x))), (fun () -> Int64.(to_string (div !Jsonrpc_client.json_rpc_read_timeout 1000000L))), "JSON RPC response read timeout value in ms"; - "json-rpc-write-timeout", Arg.Int (fun x -> Jsonrpc_client.json_rpc_write_timeout := Int64.(mul 1000000L (of_int x))), (fun () -> Int64.(to_string (div !Jsonrpc_client.json_rpc_write_timeout 1000000L))), "JSON RPC write timeout value in ms"; + "monitor_whitelist", Arg.String (fun x -> Network_monitor_thread.monitor_whitelist := Astring.String.cuts ~empty:false ~sep:"," x), (fun () -> String.concat "," !Network_monitor_thread.monitor_whitelist), "List of prefixes of interface names that are to be monitored"; + "mac-table-size", Arg.Set_int Network_utils.mac_table_size, (fun () -> string_of_int !Network_utils.mac_table_size), "Default value for the mac-table-size openvswitch parameter (see ovs-vswitchd.conf.db.5)"; + "enic-workaround-until-version", Arg.Set_string Network_server.enic_workaround_until_version, (fun () -> !Network_server.enic_workaround_until_version), "The version till enic driver workaround will be applied or the version set to an empty string for not applying the workaround."; + "pvs-proxy-socket", Arg.Set_string Network_server.PVS_proxy.path, (fun () -> !Network_server.PVS_proxy.path), "Path to the Unix domain socket for the PVS-proxy daemon"; + "igmp-query-maxresp-time", Arg.Set_string Network_utils.igmp_query_maxresp_time, (fun () -> !Network_utils.igmp_query_maxresp_time), "Maximum Response Time in IGMP Query message to send"; + "enable-ipv6-mcast-snooping", Arg.Bool (fun x -> Network_utils.enable_ipv6_mcast_snooping := x), (fun () -> string_of_bool !Network_utils.enable_ipv6_mcast_snooping), "IPv6 multicast snooping toggle"; + "mcast-snooping-disable-flood-unregistered", Arg.Bool (fun x -> Network_utils.mcast_snooping_disable_flood_unregistered := x), (fun () -> string_of_bool !Network_utils.mcast_snooping_disable_flood_unregistered), "Set OVS bridge configuration mcast-snooping-disable-flood-unregistered as 'true' or 'false'"; + "uname-cmd-path", Arg.Set_string Network_utils.uname, (fun () -> !Network_utils.uname), "Path to the Unix command uname"; + "dracut-cmd-path", Arg.Set_string Network_utils.dracut, (fun () -> !Network_utils.dracut), "Path to the Unix command dracut"; + "dracut-timeout", Arg.Set_float Network_utils.dracut_timeout, (fun () -> string_of_float !Network_utils.dracut_timeout), "Default value for the dracut command timeout"; + "modinfo-cmd-path", Arg.Set_string Network_utils.modinfo, (fun () -> !Network_utils.modinfo), "Path to the Unix command modinfo"; + "json-rpc-max-len", Arg.Set_int Jsonrpc_client.json_rpc_max_len, (fun () -> string_of_int !Jsonrpc_client.json_rpc_max_len), "Maximum buffer size for Json RPC response"; + "json-rpc-read-timeout", Arg.Int (fun x -> Jsonrpc_client.json_rpc_read_timeout := Int64.(mul 1000000L (of_int x))), (fun () -> Int64.(to_string (div !Jsonrpc_client.json_rpc_read_timeout 1000000L))), "JSON RPC response read timeout value in ms"; + "json-rpc-write-timeout", Arg.Int (fun x -> Jsonrpc_client.json_rpc_write_timeout := Int64.(mul 1000000L (of_int x))), (fun () -> Int64.(to_string (div !Jsonrpc_client.json_rpc_write_timeout 1000000L))), "JSON RPC write timeout value in ms"; ] let start server = - Network_monitor_thread.start (); - Network_server.on_startup (); - let (_: Thread.t) = Thread.create (fun () -> - Xcp_service.serve_forever server - ) () in - () + Network_monitor_thread.start (); + Network_server.on_startup (); + let (_: Thread.t) = Thread.create (fun () -> + Xcp_service.serve_forever server + ) () in + () let stop signal = - Network_server.on_shutdown signal; - Network_monitor_thread.stop (); - exit 0 + Network_server.on_shutdown signal; + Network_monitor_thread.stop (); + exit 0 let handle_shutdown () = - Sys.set_signal Sys.sigterm (Sys.Signal_handle stop); - Sys.set_signal Sys.sigint (Sys.Signal_handle stop); - Sys.set_signal Sys.sigpipe Sys.Signal_ignore + Sys.set_signal Sys.sigterm (Sys.Signal_handle stop); + Sys.set_signal Sys.sigint (Sys.Signal_handle stop); + Sys.set_signal Sys.sigpipe Sys.Signal_ignore let doc = String.concat "\n" [ - "This is the xapi toolstack network management daemon."; - ""; - "This service looks after host network configuration, including setting up bridges and/or openvswitch instances, configuring IP addresses etc."; -] + "This is the xapi toolstack network management daemon."; + ""; + "This service looks after host network configuration, including setting up bridges and/or openvswitch instances, configuring IP addresses etc."; + ] let bind () = @@ -137,38 +137,38 @@ let bind () = S.Sriov.make_vf_config Sriov.make_vf_config let _ = - Coverage.init "networkd"; - begin match Xcp_service.configure2 - ~name:Sys.argv.(0) - ~version:Version.version - ~doc ~options ~resources () with - | `Ok () -> () - | `Error m -> - Printf.fprintf stderr "%s\n" m; - exit 1 - end; - - bind (); - let server = Xcp_service.make - ~path:!Network_interface.default_path - ~queue_name:!Network_interface.queue_name - ~rpc_fn:(Idl.server Network_server.S.implementation) - () in - - Xcp_service.maybe_daemonize ~start_fn:(fun () -> - Debug.set_facility Syslog.Local5; - - (* We should make the following configurable *) - Debug.disable "http"; - - handle_shutdown (); - Debug.with_thread_associated "main" start server - ) (); - - ignore (Daemon.notify Daemon.State.Ready); - - while true do - Thread.delay 300.; - Network_server.on_timer () - done + Coverage.init "networkd"; + begin match Xcp_service.configure2 + ~name:Sys.argv.(0) + ~version:Version.version + ~doc ~options ~resources () with + | `Ok () -> () + | `Error m -> + Printf.fprintf stderr "%s\n" m; + exit 1 + end; + + bind (); + let server = Xcp_service.make + ~path:!Network_interface.default_path + ~queue_name:!Network_interface.queue_name + ~rpc_fn:(Idl.server Network_server.S.implementation) + () in + + Xcp_service.maybe_daemonize ~start_fn:(fun () -> + Debug.set_facility Syslog.Local5; + + (* We should make the following configurable *) + Debug.disable "http"; + + handle_shutdown (); + Debug.with_thread_associated "main" start server + ) (); + + ignore (Daemon.notify Daemon.State.Ready); + + while true do + Thread.delay 300.; + Network_server.on_timer () + done diff --git a/networkd_db/networkd_db.ml b/networkd_db/networkd_db.ml index ad2a19394..08d86b3e3 100644 --- a/networkd_db/networkd_db.ml +++ b/networkd_db/networkd_db.ml @@ -18,99 +18,99 @@ let name = "networkd_db" (* catch signals for clean shutdown *) let stop signal = - exit 0 + exit 0 let handle_shutdown () = - Sys.set_signal Sys.sigterm (Sys.Signal_handle stop); - Sys.set_signal Sys.sigint (Sys.Signal_handle stop); - Sys.set_signal Sys.sigpipe Sys.Signal_ignore + Sys.set_signal Sys.sigterm (Sys.Signal_handle stop); + Sys.set_signal Sys.sigint (Sys.Signal_handle stop); + Sys.set_signal Sys.sigpipe Sys.Signal_ignore let _ = - let bridge = ref "" in - let iface = ref "" in - let rc = ref 0 in - Arg.parse (Arg.align [ - "-bridge", Arg.Set_string bridge, "Bridge name"; - "-iface", Arg.Set_string iface, "Interface name"; - ]) - (fun _ -> failwith "Invalid argument") - (Printf.sprintf "Usage: %s [-bridge | -iface ]" name); + let bridge = ref "" in + let iface = ref "" in + let rc = ref 0 in + Arg.parse (Arg.align [ + "-bridge", Arg.Set_string bridge, "Bridge name"; + "-iface", Arg.Set_string iface, "Interface name"; + ]) + (fun _ -> failwith "Invalid argument") + (Printf.sprintf "Usage: %s [-bridge | -iface ]" name); - try - Coverage.init "network_db"; - let config = Network_config.read_config () in - if !bridge <> "" then - if List.mem_assoc !bridge config.bridge_config then begin - let bridge_config = List.assoc !bridge config.bridge_config in - let ifaces = List.flatten (List.map (fun (_, port) -> port.interfaces) bridge_config.ports) in - Printf.printf "interfaces=%s\n" (String.concat "," ifaces); - begin match bridge_config.vlan with - | None -> () - | Some (parent, id) -> Printf.printf "vlan=%d\nparent=%s\n" id parent - end - end else begin - rc := 1; - Printf.fprintf stderr "Could not find bridge %s\n" !bridge; - end; - if !iface <> "" then - if List.mem_assoc !iface config.interface_config then begin - let interface_config = List.assoc !iface config.interface_config in - let datav4 = match interface_config.ipv4_conf with - | DHCP4 -> - ["mode", "dhcp"] - | Static4 conf -> - let mode = ["mode", "static"] in - let addrs = - List.flatten (List.map (fun (ip, plen) -> - ["ipaddr", Unix.string_of_inet_addr ip; "netmask", prefixlen_to_netmask plen] - ) conf) - in - let gateway = match interface_config.ipv4_gateway with - | None -> [] - | Some addr -> ["gateway", Unix.string_of_inet_addr addr] - in - let dns = - let dns' = List.map Unix.string_of_inet_addr (fst interface_config.dns) in - if dns' = [] then - [] - else - ["dns", String.concat "," dns'] - in - let domains = - let domains' = snd interface_config.dns in - if domains' = [] then - [] - else - ["domain", String.concat "," domains'] - in - mode @ addrs @ gateway @ dns @ domains - | None4 -> [] - in - let datav6 = match interface_config.ipv6_conf with - | DHCP6 -> - ["modev6", "dhcp"] - | Autoconf6 -> - ["modev6", "autoconf"] - | Static6 conf -> - let mode = ["modev6", "static"] in - let addrs = - List.flatten (List.map (fun (ip, plen) -> - ["ipv6addr", (Unix.string_of_inet_addr ip) ^ "/" ^ (string_of_int plen)] - ) conf) - in - let gateway = match interface_config.ipv6_gateway with - | None -> [] - | Some addr -> ["gatewayv6", Unix.string_of_inet_addr addr] - in - mode @ addrs @ gateway - | None6 | Linklocal6 -> [] - in - let data = datav4 @ datav6 in - List.iter (fun (k, v) -> Printf.printf "%s=%s\n" k v) data - end else begin - rc := 1; - Printf.fprintf stderr "Could not find interface %s\n" !iface; - end; - with Network_config.Read_error -> - Printf.fprintf stderr "Failed to read %s\n" name; - exit !rc; + try + Coverage.init "network_db"; + let config = Network_config.read_config () in + if !bridge <> "" then + if List.mem_assoc !bridge config.bridge_config then begin + let bridge_config = List.assoc !bridge config.bridge_config in + let ifaces = List.flatten (List.map (fun (_, port) -> port.interfaces) bridge_config.ports) in + Printf.printf "interfaces=%s\n" (String.concat "," ifaces); + begin match bridge_config.vlan with + | None -> () + | Some (parent, id) -> Printf.printf "vlan=%d\nparent=%s\n" id parent + end + end else begin + rc := 1; + Printf.fprintf stderr "Could not find bridge %s\n" !bridge; + end; + if !iface <> "" then + if List.mem_assoc !iface config.interface_config then begin + let interface_config = List.assoc !iface config.interface_config in + let datav4 = match interface_config.ipv4_conf with + | DHCP4 -> + ["mode", "dhcp"] + | Static4 conf -> + let mode = ["mode", "static"] in + let addrs = + List.flatten (List.map (fun (ip, plen) -> + ["ipaddr", Unix.string_of_inet_addr ip; "netmask", prefixlen_to_netmask plen] + ) conf) + in + let gateway = match interface_config.ipv4_gateway with + | None -> [] + | Some addr -> ["gateway", Unix.string_of_inet_addr addr] + in + let dns = + let dns' = List.map Unix.string_of_inet_addr (fst interface_config.dns) in + if dns' = [] then + [] + else + ["dns", String.concat "," dns'] + in + let domains = + let domains' = snd interface_config.dns in + if domains' = [] then + [] + else + ["domain", String.concat "," domains'] + in + mode @ addrs @ gateway @ dns @ domains + | None4 -> [] + in + let datav6 = match interface_config.ipv6_conf with + | DHCP6 -> + ["modev6", "dhcp"] + | Autoconf6 -> + ["modev6", "autoconf"] + | Static6 conf -> + let mode = ["modev6", "static"] in + let addrs = + List.flatten (List.map (fun (ip, plen) -> + ["ipv6addr", (Unix.string_of_inet_addr ip) ^ "/" ^ (string_of_int plen)] + ) conf) + in + let gateway = match interface_config.ipv6_gateway with + | None -> [] + | Some addr -> ["gatewayv6", Unix.string_of_inet_addr addr] + in + mode @ addrs @ gateway + | None6 | Linklocal6 -> [] + in + let data = datav4 @ datav6 in + List.iter (fun (k, v) -> Printf.printf "%s=%s\n" k v) data + end else begin + rc := 1; + Printf.fprintf stderr "Could not find interface %s\n" !iface; + end; + with Network_config.Read_error -> + Printf.fprintf stderr "Failed to read %s\n" name; + exit !rc; diff --git a/profiling/coverage.ml b/profiling/coverage.ml index 1dbdff6a6..2d0b60a89 100644 --- a/profiling/coverage.ml +++ b/profiling/coverage.ml @@ -1,18 +1,18 @@ (** This module sets up the env variable for bisect_ppx which describes * where log files are written. - *) +*) (** [init name] sets up coverage profiling for binary [name]. You could * use [Sys.argv.(0)] for [name]. - *) +*) let init name = let (//) = Filename.concat in let tmpdir = Filename.get_temp_dir_name () in - try - ignore (Sys.getenv "BISECT_FILE") - with Not_found -> - Unix.putenv "BISECT_FILE" (tmpdir // Printf.sprintf "bisect-%s-" name) + try + ignore (Sys.getenv "BISECT_FILE") + with Not_found -> + Unix.putenv "BISECT_FILE" (tmpdir // Printf.sprintf "bisect-%s-" name) diff --git a/profiling/coverage.mli b/profiling/coverage.mli index f9a84b34e..9b2cc50f8 100644 --- a/profiling/coverage.mli +++ b/profiling/coverage.mli @@ -2,6 +2,6 @@ (** [init name] sets up coverage profiling for binary [name]. You could * use [Sys.argv.(0) for name - *) +*) val init: string -> unit diff --git a/test/jsonrpc_dummy.ml b/test/jsonrpc_dummy.ml index b291222be..c5a593638 100644 --- a/test/jsonrpc_dummy.ml +++ b/test/jsonrpc_dummy.ml @@ -1,14 +1,14 @@ let path = Sys.argv.(1) let _ = - Sys.set_signal Sys.sigint (Sys.Signal_handle (fun _ -> Unix.unlink path; exit 0)); - Unix.establish_server (fun fin fout -> - let rec loop () = - let json = Jsonrpc_client.input_json_object fin in - Printf.printf "Received: %s\n" json; - let response = Jsonrpc.string_of_response ~version:Jsonrpc.V2 (Rpc.success (Rpc.String "Thanks!")) in - Printf.printf "Response: %s\n" response; - output_string fout response - in - loop () - ) (Unix.ADDR_UNIX path) + Sys.set_signal Sys.sigint (Sys.Signal_handle (fun _ -> Unix.unlink path; exit 0)); + Unix.establish_server (fun fin fout -> + let rec loop () = + let json = Jsonrpc_client.input_json_object fin in + Printf.printf "Received: %s\n" json; + let response = Jsonrpc.string_of_response ~version:Jsonrpc.V2 (Rpc.success (Rpc.String "Thanks!")) in + Printf.printf "Response: %s\n" response; + output_string fout response + in + loop () + ) (Unix.ADDR_UNIX path) diff --git a/test/network_test.ml b/test/network_test.ml index e508e117e..3d2ba46cc 100644 --- a/test/network_test.ml +++ b/test/network_test.ml @@ -15,11 +15,11 @@ open OUnit let base_suite = - "base_suite" >::: - [ - Network_test_lacp_properties.suite; - Test_jsonrpc_client.suite; - ] + "base_suite" >::: + [ + Network_test_lacp_properties.suite; + Test_jsonrpc_client.suite; + ] let _ = Coverage.init "network_test"; diff --git a/test/network_test_lacp_properties.ml b/test/network_test_lacp_properties.ml index f8c23c419..c319554c1 100644 --- a/test/network_test_lacp_properties.ml +++ b/test/network_test_lacp_properties.ml @@ -18,112 +18,112 @@ open Network_utils (* Example of using OUnitDiff with a String Set *) module StringDiff = struct - type t = string - let compare = String.compare - let pp_printer = Format.pp_print_string - let pp_print_sep = OUnitDiff.pp_comma_separator + type t = string + let compare = String.compare + let pp_printer = Format.pp_print_string + let pp_print_sep = OUnitDiff.pp_comma_separator end module OSSet = OUnitDiff.SetMake(StringDiff) let run_bond_prop_test props c_props c_per_iface = - let props, per_iface_props = - Ovs.make_bond_properties "bond_test" props in + let props, per_iface_props = + Ovs.make_bond_properties "bond_test" props in - let propset = OSSet.of_list props in - let correctset = OSSet.of_list c_props in - OSSet.assert_equal correctset propset ; + let propset = OSSet.of_list props in + let correctset = OSSet.of_list c_props in + OSSet.assert_equal correctset propset ; - let propset = OSSet.of_list per_iface_props in - let correctset = OSSet.of_list c_per_iface in - OSSet.assert_equal correctset propset + let propset = OSSet.of_list per_iface_props in + let correctset = OSSet.of_list c_per_iface in + OSSet.assert_equal correctset propset let test_lacp_timeout_prop arg () = - let props = [ "mode", "lacp" ; "lacp-time", arg ; ] - and correct_props = - [ "lacp=active"; - "bond_mode=balance-tcp"; - Printf.sprintf "other-config:lacp-time=\"%s\"" arg ] - and correct_iface_props = [ ] in + let props = [ "mode", "lacp" ; "lacp-time", arg ; ] + and correct_props = + [ "lacp=active"; + "bond_mode=balance-tcp"; + Printf.sprintf "other-config:lacp-time=\"%s\"" arg ] + and correct_iface_props = [ ] in - run_bond_prop_test props correct_props correct_iface_props + run_bond_prop_test props correct_props correct_iface_props let test_lacp_aggregation_key arg () = - let props, per_iface_props = Ovs.make_bond_properties "bond_test" - [ "mode", "lacp" ; "lacp-aggregation-key", arg ] - and correct_props = [ - "lacp=active"; - "bond_mode=balance-tcp"; - ] - and correct_iface_props = [ - Printf.sprintf "other-config:lacp-aggregation-key=\"%s\"" arg ; - ] in + let props, per_iface_props = Ovs.make_bond_properties "bond_test" + [ "mode", "lacp" ; "lacp-aggregation-key", arg ] + and correct_props = [ + "lacp=active"; + "bond_mode=balance-tcp"; + ] + and correct_iface_props = [ + Printf.sprintf "other-config:lacp-aggregation-key=\"%s\"" arg ; + ] in - let propset = OSSet.of_list props in - let correctset = OSSet.of_list correct_props in - OSSet.assert_equal correctset propset ; + let propset = OSSet.of_list props in + let correctset = OSSet.of_list correct_props in + OSSet.assert_equal correctset propset ; - let propset = OSSet.of_list per_iface_props in - let correctset = OSSet.of_list correct_iface_props in - OSSet.assert_equal correctset propset + let propset = OSSet.of_list per_iface_props in + let correctset = OSSet.of_list correct_iface_props in + OSSet.assert_equal correctset propset module OVS_Cli_test = struct - include Ovs.Cli - let vsctl_output = ref [] - let vsctl ?(log=true) args = - vsctl_output := args ; - String.concat " " args + include Ovs.Cli + let vsctl_output = ref [] + let vsctl ?(log=true) args = + vsctl_output := args ; + String.concat " " args end (* XXX TODO write this test *) let test_lacp_aggregation_key_vsctl arg () = skip_if true "Unimplemented" ; - let module Ovs = Ovs.Make(OVS_Cli_test) in - let bond = "bond0" - and ifaces = ["eth0"; "eth1"] - and bridge = "xapi1" - and props = [ "mode", "lacp" ; "lacp-aggregation-key", arg ] - (* other-config:lacp-aggregation-key=42 *) - and answer = "other-config:lacp-aggregation-key=" ^ arg - in - Ovs.create_bond bond ifaces bridge props |> ignore ; - List.iter print_endline !OVS_Cli_test.vsctl_output ; - print_endline answer ; - assert_bool "lacp_aggregation_key is passed to ovs-vsctl command" - (List.exists - (fun s -> (String.trim s) == answer) - !OVS_Cli_test.vsctl_output) + let module Ovs = Ovs.Make(OVS_Cli_test) in + let bond = "bond0" + and ifaces = ["eth0"; "eth1"] + and bridge = "xapi1" + and props = [ "mode", "lacp" ; "lacp-aggregation-key", arg ] + (* other-config:lacp-aggregation-key=42 *) + and answer = "other-config:lacp-aggregation-key=" ^ arg + in + Ovs.create_bond bond ifaces bridge props |> ignore ; + List.iter print_endline !OVS_Cli_test.vsctl_output ; + print_endline answer ; + assert_bool "lacp_aggregation_key is passed to ovs-vsctl command" + (List.exists + (fun s -> (String.trim s) == answer) + !OVS_Cli_test.vsctl_output) (* Test case for bond_create with default lacp-{time,aggregation-key} settings. This should not call ovs-vsctl with unfinished key=value arguments. So we shouldn't have somthing like "other-config:lacp-aggregation-key= ". *) let test_lacp_defaults_bond_create () = - let module Ovs = Ovs.Make(OVS_Cli_test) in - let bond = "bond0" - and ifaces = ["eth0"; "eth1"] - and bridge = "xapi1" - and default_props = [ - "mode", "lacp"; - "lacp-time", "slow"; - "hashing_algorithm", "tcpudp_ports"; - ] - in - Ovs.create_bond bond ifaces bridge default_props |> ignore; - (* should not have any strings which contain lacp-aggregation-key *) - (*assert_bool "no default property for lacp_aggregation_key" - List.exists (fun s -> String.*) - List.iter - (fun arg -> - assert_bool "key=value argument pairs can't have missing values" - (let open Astring.String in - arg |> trim |> is_suffix ~affix:"=" |> not)) - !OVS_Cli_test.vsctl_output + let module Ovs = Ovs.Make(OVS_Cli_test) in + let bond = "bond0" + and ifaces = ["eth0"; "eth1"] + and bridge = "xapi1" + and default_props = [ + "mode", "lacp"; + "lacp-time", "slow"; + "hashing_algorithm", "tcpudp_ports"; + ] + in + Ovs.create_bond bond ifaces bridge default_props |> ignore; + (* should not have any strings which contain lacp-aggregation-key *) + (*assert_bool "no default property for lacp_aggregation_key" + List.exists (fun s -> String.*) + List.iter + (fun arg -> + assert_bool "key=value argument pairs can't have missing values" + (let open Astring.String in + arg |> trim |> is_suffix ~affix:"=" |> not)) + !OVS_Cli_test.vsctl_output let suite = - "lacp_properties" >::: - [ - "test_lacp_timeout_prop(slow)" >:: test_lacp_timeout_prop "slow"; - "test_lacp_timeout_prop(fast)" >:: test_lacp_timeout_prop "fast"; - "test_lacp_aggregation_key(42)" >:: test_lacp_aggregation_key "42"; - "test_lacp_aggregation_key_vsctl" >:: test_lacp_aggregation_key_vsctl "42"; - "test_lacp_defaults_bond_create" >:: test_lacp_defaults_bond_create; - ] + "lacp_properties" >::: + [ + "test_lacp_timeout_prop(slow)" >:: test_lacp_timeout_prop "slow"; + "test_lacp_timeout_prop(fast)" >:: test_lacp_timeout_prop "fast"; + "test_lacp_aggregation_key(42)" >:: test_lacp_aggregation_key "42"; + "test_lacp_aggregation_key_vsctl" >:: test_lacp_aggregation_key_vsctl "42"; + "test_lacp_defaults_bond_create" >:: test_lacp_defaults_bond_create; + ] diff --git a/test/test_jsonrpc_client.ml b/test/test_jsonrpc_client.ml index a3a7f31aa..b2f3c4e51 100644 --- a/test/test_jsonrpc_client.ml +++ b/test/test_jsonrpc_client.ml @@ -19,56 +19,56 @@ open Xapi_stdext_monadic.Either let dir = Filename.concat "test" "jsonrpc_files" let jsonrpc_printer : Rpc.t Test_printers.printer = - Jsonrpc.to_string + Jsonrpc.to_string module Input_json_object = Generic.Make (struct - module Io = struct - type input_t = string - type output_t = (exn, Rpc.t) Xapi_stdext_monadic.Either.t - let string_of_input_t = Test_printers.string - let string_of_output_t = Test_printers.(either exn jsonrpc_printer) - end + module Io = struct + type input_t = string + type output_t = (exn, Rpc.t) Xapi_stdext_monadic.Either.t + let string_of_input_t = Test_printers.string + let string_of_output_t = Test_printers.(either exn jsonrpc_printer) + end - let good_call = - let fin = open_in (Filename.concat dir "good_call.json") in - let s = input_line fin in - close_in fin; - Jsonrpc.of_string s + let good_call = + let fin = open_in (Filename.concat dir "good_call.json") in + let s = input_line fin in + close_in fin; + Jsonrpc.of_string s - exception Parse_error + exception Parse_error - let transform filename = - let fin = open_in (Filename.concat dir filename) in - let response = - try - let json = Jsonrpc_client.timeout_read (Unix.descr_of_in_channel fin) 5_000_000_000L in - let rpc = Jsonrpc.of_string ~strict:false json in - Right rpc - with - | End_of_file -> Left End_of_file - | _ -> Left Parse_error - in - close_in fin; - response + let transform filename = + let fin = open_in (Filename.concat dir filename) in + let response = + try + let json = Jsonrpc_client.timeout_read (Unix.descr_of_in_channel fin) 5_000_000_000L in + let rpc = Jsonrpc.of_string ~strict:false json in + Right rpc + with + | End_of_file -> Left End_of_file + | _ -> Left Parse_error + in + close_in fin; + response - let tests = [ - (* A file containing exactly one JSON object. *) - (* It has got curly braces inside strings to make it interesting. *) - "good_call.json", Right good_call; + let tests = [ + (* A file containing exactly one JSON object. *) + (* It has got curly braces inside strings to make it interesting. *) + "good_call.json", Right good_call; - (* A file containing a partial JSON object. *) - "short_call.json", Left Parse_error; + (* A file containing a partial JSON object. *) + "short_call.json", Left Parse_error; - (* A file containing a JSON object, plus some more characters at the end. *) - "good_call_plus.json", Right good_call; + (* A file containing a JSON object, plus some more characters at the end. *) + "good_call_plus.json", Right good_call; - (* A file containing some invalid JSON object. *) - "bad_call.json", (Left Parse_error); - ] -end) + (* A file containing some invalid JSON object. *) + "bad_call.json", (Left Parse_error); + ] + end) let suite = - "jsonrpc_client" >::: - [ - "input_json_object" >::: Input_json_object.tests; - ] + "jsonrpc_client" >::: + [ + "input_json_object" >::: Input_json_object.tests; + ] From 15fca74359eec927d5216bbc40909cdf651e911a Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 28 Sep 2018 16:06:39 +0100 Subject: [PATCH 193/260] Fix error reporting In the new PPX IDL, all errors that are defined in `Network_interface` need to be raise as `Network_error`. If not, they will all be turned into `Network_error.Internal_error` exceptions. Signed-off-by: Rob Hoes --- lib/network_utils.ml | 22 +++++++++------------- networkd/network_server.ml | 18 +++++++++--------- 2 files changed, 18 insertions(+), 22 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 0e8cecc95..6012833f9 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -19,13 +19,6 @@ open Network_interface module D = Debug.Make(struct let name = "network_utils" end) open D -exception Script_missing of string -exception Script_error of (string * string) list -exception Read_error of string -exception Write_error of string -exception Not_implemented -exception Vlan_in_use of (string * int) -exception PVS_proxy_connection_error type util_error = | Bus_out_of_range @@ -78,7 +71,7 @@ let check_n_run run_func script args = | Unix.Unix_error (e, a, b) -> error "Caught unix error: %s [%s, %s]" (Unix.error_message e) a b; error "Assuming script %s doesn't exist" script; - raise (Script_missing script) + raise (Network_error (Script_missing script)) | Forkhelpers.Spawn_internal_error(stderr, stdout, e)-> let message = match e with @@ -88,8 +81,11 @@ let check_n_run run_func script args = in error "Call '%s %s' exited badly: %s [stdout = '%s'; stderr = '%s']" script (String.concat " " args) message stdout stderr; - raise (Script_error ["script", script; "args", String.concat " " args; "code", - message; "stdout", stdout; "stderr", stderr]) + raise (Network_error (Script_error ["script", script; + "args", String.concat " " args; + "code", message; + "stdout", stdout; + "stderr", stderr])) let call_script ?(log_successful_output=false) ?(timeout=Some 60.0) script args = let call_script_internal env script args = @@ -136,18 +132,18 @@ module Sysfs = struct with | End_of_file -> "" (* Match the exception when the device state if off *) - | Sys_error("Invalid argument") -> raise (Read_error file) + | Sys_error("Invalid argument") -> raise (Network_error (Read_error file)) | exn -> error "Error in read one line of file: %s, exception %s\n%s" file (Printexc.to_string exn) (Printexc.get_backtrace ()); - raise (Read_error file) + raise (Network_error (Read_error file)) let write_one_line file l = let outchan = open_out file in try output_string outchan (l ^ "\n"); close_out outchan - with exn -> close_out outchan; raise (Write_error file) + with exn -> close_out outchan; raise (Network_error (Write_error file)) let is_physical name = try diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 17df07038..e64295277 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -735,7 +735,7 @@ module Bridge = struct * device name or not on the requested bridge is bad. *) if parent' = parent && vlan' = vlan && (device <> vlan_name || not (List.mem device bridge_interfaces)) then - raise (Vlan_in_use (parent, vlan)) + raise (Network_error (Vlan_in_use (parent, vlan))) ) (Proc.get_vlans ()); (* Robustness enhancement: ensure there are no other VLANs in the bridge *) let current_interfaces = List.filter (fun n -> @@ -817,7 +817,7 @@ module Bridge = struct Debug.with_thread_associated dbg (fun () -> match !backend_kind with | Openvswitch -> Ovs.bridge_to_ports name - | Bridge -> raise Not_implemented + | Bridge -> raise (Network_error Not_implemented) ) () let get_all_ports dbg from_cache = @@ -828,14 +828,14 @@ module Bridge = struct else match !backend_kind with | Openvswitch -> List.concat (List.map Ovs.bridge_to_ports (Ovs.list_bridges ())) - | Bridge -> raise Not_implemented + | Bridge -> raise (Network_error Not_implemented) ) () let get_bonds _ dbg ~name = Debug.with_thread_associated dbg (fun () -> match !backend_kind with | Openvswitch -> Ovs.bridge_to_ports name - | Bridge -> raise Not_implemented + | Bridge -> raise (Network_error Not_implemented) ) () let get_all_bonds dbg from_cache = @@ -847,7 +847,7 @@ module Bridge = struct else match !backend_kind with | Openvswitch -> List.concat (List.map Ovs.bridge_to_ports (Ovs.list_bridges ())) - | Bridge -> raise Not_implemented + | Bridge -> raise (Network_error Not_implemented) ) () type bond_link_info = { @@ -892,7 +892,7 @@ module Bridge = struct Debug.with_thread_associated dbg (fun () -> match !backend_kind with | Openvswitch -> Ovs.bridge_to_vlan name - | Bridge -> raise Not_implemented + | Bridge -> raise (Network_error Not_implemented) ) () let add_default_flows _ dbg bridge mac interfaces = @@ -962,7 +962,7 @@ module Bridge = struct Ovs.mod_port real_bridge name "no-flood"; Interface.bring_up () dbg ~name | Bridge -> - raise Not_implemented + raise (Network_error Not_implemented) let add_port dbg bond_mac bridge name interfaces bond_properties kind = Debug.with_thread_associated dbg (fun () -> @@ -1052,7 +1052,7 @@ module Bridge = struct | "secure" -> Some Secure | _ -> None end - | Bridge -> raise Not_implemented + | Bridge -> raise (Network_error Not_implemented) ) () let is_persistent _ dbg ~name = @@ -1121,7 +1121,7 @@ module PVS_proxy = struct Jsonrpc_client.with_rpc ~path:!path ~call () with e -> error "Error when calling PVS proxy: %s" (Printexc.to_string e); - raise PVS_proxy_connection_error + raise (Network_error PVS_proxy_connection_error) let configure_site dbg config = debug "Configuring PVS proxy for site %s" config.site_uuid; From 575b4eeee6a58e8253fddc60428f0588d039a5e0 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 28 Sep 2018 16:39:09 +0100 Subject: [PATCH 194/260] Confirm that the interface exists before calling `ip` The logs are full of errors from commands such as `ip addr show` complaining that the given interface does not exist. A Script_error exception would be raised in such cases, which is usually caught and thrown away higher up the stack. Still, the alarming log message is left behind, which often confuses people. Instead of calling out to the `ip` command and hoping for the best, we now first check whether the interface actually exists, and raise the new Interface_does_not_exist error if not. Signed-off-by: Rob Hoes --- lib/network_utils.ml | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 6012833f9..d841b6c74 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -106,6 +106,13 @@ module Sysfs = struct let all = Array.to_list (Sys.readdir "/sys/class/net") in List.filter (fun name -> Sys.is_directory ("/sys/class/net/" ^ name)) all + let exists dev = + List.mem dev @@ list () + + let assert_exists dev = + if not @@ exists dev then + raise (Network_error (Interface_does_not_exist dev)) + let list_drivers () = try Array.to_list (Sys.readdir "/sys/bus/pci/drivers") @@ -357,6 +364,7 @@ module Ip = struct List.map (fun i -> List.nth args (succ i)) indices let get_link_flags dev = + Sysfs.assert_exists dev; let output = call ["link"; "show"; "dev"; dev] in let i = String.index output '<' in let j = String.index output '>' in @@ -369,11 +377,13 @@ module Ip = struct with _ -> false let link_set dev args = + Sysfs.assert_exists dev; ignore (call ~log:true ("link" :: "set" :: dev :: args)) let link_set_mtu dev mtu = try ignore (link_set dev ["mtu"; string_of_int mtu]) - with e -> error "MTU size is not supported: %s" (string_of_int mtu) + with Network_error (Script_error _) -> + error "MTU size is not supported: %d" mtu let link_set_up dev = link_set dev ["up"] @@ -390,11 +400,13 @@ module Ip = struct (fun () -> List.iter link_set_up up_links) let link ?(version=V46) dev attr = + Sysfs.assert_exists dev; let v = string_of_version version in let output = call (v @ ["link"; "show"; "dev"; dev]) in find output attr let addr ?(version=V46) dev attr = + Sysfs.assert_exists dev; let v = string_of_version version in let output = call (v @ ["addr"; "show"; "dev"; dev]) in find output attr @@ -487,6 +499,7 @@ module Ip = struct let flush_ip_addr ?(ipv6=false) dev = try + Sysfs.assert_exists dev; let mode = if ipv6 then "-6" else "-4" in ignore (call ~log:true [mode; "addr"; "flush"; "dev"; dev]) with _ -> () @@ -494,6 +507,7 @@ module Ip = struct let del_ip_addr dev (ip, prefixlen) = let addr = Printf.sprintf "%s/%d" (Unix.string_of_inet_addr ip) prefixlen in try + Sysfs.assert_exists dev; ignore (call ~log:true ["addr"; "del"; addr; "dev"; dev]) with _ -> () @@ -503,6 +517,7 @@ module Ip = struct let set_route ?network dev gateway = try + Sysfs.assert_exists dev; match network with | None -> ignore (call ~log:true ["route"; "replace"; "default"; "via"; Unix.string_of_inet_addr gateway; "dev"; dev]) @@ -517,12 +532,12 @@ module Ip = struct Printf.sprintf "%s.%d" interface vlan let create_vlan interface vlan = - if not (List.mem (vlan_name interface vlan) (Sysfs.list ())) then + if not (Sysfs.exists (vlan_name interface vlan)) then ignore (call ~log:true ["link"; "add"; "link"; interface; "name"; vlan_name interface vlan; "type"; "vlan"; "id"; string_of_int vlan]) let destroy_vlan name = - if List.mem name (Sysfs.list ()) then + if Sysfs.exists name then ignore (call ~log:true ["link"; "delete"; name]) let set_vf_mac dev index mac = From 86dcc59ce094c16b01b016e47097065d2e2824e3 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Mon, 1 Oct 2018 16:01:10 +0100 Subject: [PATCH 195/260] Eliminate compiler warning 52 Signed-off-by: Rob Hoes --- lib/network_utils.ml | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index d841b6c74..1a32ad56f 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -132,14 +132,15 @@ module Sysfs = struct let read_one_line file = try - let inchan = open_in file in - Pervasiveext.finally - (fun () -> input_line inchan) - (fun () -> close_in inchan) + Unixext.string_of_file file + |> String.split_on_char '\n' + |> List.hd + (* Note: the list returned by split_on_char is guaranteed to be non-empty *) with | End_of_file -> "" - (* Match the exception when the device state if off *) - | Sys_error("Invalid argument") -> raise (Network_error (Read_error file)) + | Unix.Unix_error (Unix.EINVAL, _, _) -> + (* The device is not yet up *) + raise (Network_error (Read_error file)) | exn -> error "Error in read one line of file: %s, exception %s\n%s" file (Printexc.to_string exn) (Printexc.get_backtrace ()); From 28480024df2d8d5785564a107290b1912aae868e Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Mon, 1 Oct 2018 15:40:27 +0100 Subject: [PATCH 196/260] Remove log_successful_output from call_script This has not actually been working for many years. We did not miss it. Signed-off-by: Rob Hoes --- lib/network_utils.ml | 116 +++++++++++++-------------- test/network_test_lacp_properties.ml | 2 +- 2 files changed, 59 insertions(+), 59 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 1a32ad56f..d563e2e93 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -87,7 +87,7 @@ let check_n_run run_func script args = "stdout", stdout; "stderr", stderr])) -let call_script ?(log_successful_output=false) ?(timeout=Some 60.0) script args = +let call_script ?(timeout=Some 60.0) script args = let call_script_internal env script args = let (out,err) = Forkhelpers.execute_command_get_output ~env ?timeout script args in out @@ -354,8 +354,8 @@ module Ip = struct | V6 -> ["-6"] | V46 -> [] - let call ?(log=false) args = - call_script ~log_successful_output:log iproute2 args + let call args = + call_script iproute2 args let find output attr = info "Looking for %s in [%s]" attr output; @@ -379,7 +379,7 @@ module Ip = struct let link_set dev args = Sysfs.assert_exists dev; - ignore (call ~log:true ("link" :: "set" :: dev :: args)) + ignore (call ("link" :: "set" :: dev :: args)) let link_set_mtu dev mtu = try ignore (link_set dev ["mtu"; string_of_int mtu]) @@ -489,27 +489,27 @@ module Ip = struct else [] in try - ignore (call ~log:true (["addr"; "add"; addr; "dev"; dev] @ broadcast)) + ignore (call (["addr"; "add"; addr; "dev"; dev] @ broadcast)) with _ -> () let set_ipv6_link_local_addr dev = let addr = get_ipv6_link_local_addr dev in try - ignore (call ~log:true ["addr"; "add"; addr; "dev"; dev; "scope"; "link"]) + ignore (call ["addr"; "add"; addr; "dev"; dev; "scope"; "link"]) with _ -> () let flush_ip_addr ?(ipv6=false) dev = try Sysfs.assert_exists dev; let mode = if ipv6 then "-6" else "-4" in - ignore (call ~log:true [mode; "addr"; "flush"; "dev"; dev]) + ignore (call [mode; "addr"; "flush"; "dev"; dev]) with _ -> () let del_ip_addr dev (ip, prefixlen) = let addr = Printf.sprintf "%s/%d" (Unix.string_of_inet_addr ip) prefixlen in try Sysfs.assert_exists dev; - ignore (call ~log:true ["addr"; "del"; addr; "dev"; dev]) + ignore (call ["addr"; "del"; addr; "dev"; dev]) with _ -> () let route_show ?(version=V46) dev = @@ -521,10 +521,10 @@ module Ip = struct Sysfs.assert_exists dev; match network with | None -> - ignore (call ~log:true ["route"; "replace"; "default"; "via"; Unix.string_of_inet_addr gateway; "dev"; dev]) + ignore (call ["route"; "replace"; "default"; "via"; Unix.string_of_inet_addr gateway; "dev"; dev]) | Some (ip, prefixlen) -> let addr = Printf.sprintf "%s/%d" (Unix.string_of_inet_addr ip) prefixlen in - ignore (call ~log:true ["route"; "replace"; addr; "via"; Unix.string_of_inet_addr gateway; "dev"; dev]) + ignore (call ["route"; "replace"; addr; "via"; Unix.string_of_inet_addr gateway; "dev"; dev]) with _ -> () let set_gateway dev gateway = set_route dev gateway @@ -534,12 +534,12 @@ module Ip = struct let create_vlan interface vlan = if not (Sysfs.exists (vlan_name interface vlan)) then - ignore (call ~log:true ["link"; "add"; "link"; interface; "name"; vlan_name interface vlan; + ignore (call ["link"; "add"; "link"; interface; "name"; vlan_name interface vlan; "type"; "vlan"; "id"; string_of_int vlan]) let destroy_vlan name = if Sysfs.exists name then - ignore (call ~log:true ["link"; "delete"; name]) + ignore (call ["link"; "delete"; name]) let set_vf_mac dev index mac = try @@ -779,17 +779,17 @@ module Dhclient = struct | _ -> l) [] options in write_conf_file ~ipv6 interface options; let ipv6' = if ipv6 then ["-6"] else [] in - call_script ~log_successful_output:true ~timeout:None dhclient (ipv6' @ gw_opt @ ["-q"; - "-pf"; pid_file ~ipv6 interface; - "-lf"; lease_file ~ipv6 interface; - "-cf"; conf_file ~ipv6 interface; - interface]) + call_script ~timeout:None dhclient (ipv6' @ gw_opt @ ["-q"; + "-pf"; pid_file ~ipv6 interface; + "-lf"; lease_file ~ipv6 interface; + "-cf"; conf_file ~ipv6 interface; + interface]) let stop ?(ipv6=false) interface = try - ignore (call_script ~log_successful_output:true dhclient ["-r"; - "-pf"; pid_file ~ipv6 interface; - interface]); + ignore (call_script dhclient ["-r"; + "-pf"; pid_file ~ipv6 interface; + interface]); Unix.unlink (pid_file ~ipv6 interface) with _ -> () @@ -816,8 +816,8 @@ module Dhclient = struct end module Fcoe = struct - let call ?(log=false) args = - call_script ~log_successful_output:log ~timeout:(Some 10.0) !fcoedriver args + let call args = + call_script ~timeout:(Some 10.0) !fcoedriver args let get_capabilities name = try @@ -830,7 +830,7 @@ end module Sysctl = struct let write value variable = - ignore (call_script ~log_successful_output:true sysctl ["-q"; "-w"; variable ^ "=" ^ value]) + ignore (call_script sysctl ["-q"; "-w"; variable ^ "=" ^ value]) let set_ipv6_autoconf interface value = try @@ -904,20 +904,20 @@ end module Ovs = struct module Cli : sig - val vsctl : ?log:bool -> string list -> string - val ofctl : ?log:bool -> string list -> string - val appctl : ?log:bool -> string list -> string + val vsctl : string list -> string + val ofctl : string list -> string + val appctl : string list -> string end = struct open Xapi_stdext_threads let s = Semaphore.create 5 - let vsctl ?(log=false) args = + let vsctl args = Semaphore.execute s (fun () -> - call_script ~log_successful_output:log ovs_vsctl ("--timeout=20" :: args) + call_script ovs_vsctl ("--timeout=20" :: args) ) - let ofctl ?(log=false) args = - call_script ~log_successful_output:log ovs_ofctl args - let appctl ?(log=false) args = - call_script ~log_successful_output:log ovs_appctl args + let ofctl args = + call_script ovs_ofctl args + let appctl args = + call_script ovs_appctl args end module type Cli_S = module type of Cli @@ -1044,7 +1044,7 @@ module Ovs = struct in let setting = if do_workaround then "on" else "off" in (try - ignore (call_script ~log_successful_output:true ovs_vlan_bug_workaround [interface; setting]); + ignore (call_script ovs_vlan_bug_workaround [interface; setting]); with _ -> ()); ) phy_interfaces @@ -1081,7 +1081,7 @@ module Ovs = struct let get_mcast_snooping_enable ~name = try - vsctl ~log:true ["--"; "get"; "bridge"; name; "mcast_snooping_enable"] + vsctl ["--"; "get"; "bridge"; name; "mcast_snooping_enable"] |> String.trim |> bool_of_string with _ -> false @@ -1158,11 +1158,11 @@ module Ovs = struct ["--"; "set"; "bridge"; name; "other_config:mcast-snooping-disable-flood-unregistered=" ^ (string_of_bool !mcast_snooping_disable_flood_unregistered)] | _ -> [] in - vsctl ~log:true (del_old_arg @ ["--"; "--may-exist"; "add-br"; name] @ + vsctl (del_old_arg @ ["--"; "--may-exist"; "add-br"; name] @ vlan_arg @ mac_arg @ fail_mode_arg @ disable_in_band_arg @ external_id_arg @ vif_arg @ set_mac_table_size @ set_igmp_snooping @ set_ipv6_igmp_snooping @ disable_flood_unregistered) let destroy_bridge name = - vsctl ~log:true ["--"; "--if-exists"; "del-br"; name] + vsctl ["--"; "--if-exists"; "del-br"; name] let list_bridges () = let bridges = String.trim (vsctl ["list-br"]) in @@ -1174,13 +1174,13 @@ module Ovs = struct let create_port ?(internal=false) name bridge = let type_args = if internal then ["--"; "set"; "interface"; name; "type=internal"] else [] in - vsctl ~log:true (["--"; "--may-exist"; "add-port"; bridge; name] @ type_args) + vsctl (["--"; "--may-exist"; "add-port"; bridge; name] @ type_args) let destroy_port name = - vsctl ~log:true ["--"; "--with-iface"; "--if-exists"; "del-port"; name] + vsctl ["--"; "--with-iface"; "--if-exists"; "del-port"; name] let port_to_bridge name = - vsctl ~log:true ["port-to-br"; name] + vsctl ["port-to-br"; name] let make_bond_properties name properties = let known_props = ["mode"; "hashing-algorithm"; "updelay"; "downdelay"; @@ -1256,7 +1256,7 @@ module Ovs = struct ["--"; "set"; "interface"; iface ] @ per_iface_args) interfaces) in - vsctl ~log:true (["--"; "--may-exist"; "add-bond"; bridge; name] @ interfaces @ + vsctl (["--"; "--may-exist"; "add-bond"; bridge; name] @ interfaces @ mac_args @ args @ per_iface_args) let get_fail_mode bridge = @@ -1278,58 +1278,58 @@ module Ovs = struct Printf.sprintf "idle_timeout=0,priority=0,in_port=%s,dl_dst=%s,actions=local" port mac] ) ports) in - List.iter (fun flow -> ignore (ofctl ~log:true ["add-flow"; bridge; flow])) flows + List.iter (fun flow -> ignore (ofctl ["add-flow"; bridge; flow])) flows let mod_port bridge port action = - ofctl ~log:true ["mod-port"; bridge; port; action] |> ignore + ofctl ["mod-port"; bridge; port; action] |> ignore let set_mtu interface mtu = - vsctl ~log:true ["set"; "interface"; interface; Printf.sprintf "mtu_request=%d" mtu] + vsctl ["set"; "interface"; interface; Printf.sprintf "mtu_request=%d" mtu] end include Make(Cli) end module Brctl = struct - let call ?(log=false) args = - call_script ~log_successful_output:log !brctl args + let call args = + call_script !brctl args let create_bridge name = if not (List.mem name (Sysfs.list ())) then - ignore (call ~log:true ["addbr"; name]) + ignore (call ["addbr"; name]) let destroy_bridge name = if List.mem name (Sysfs.list ()) then - ignore (call ~log:true ["delbr"; name]) + ignore (call ["delbr"; name]) let create_port bridge name = if not (List.mem name (Sysfs.bridge_to_interfaces bridge)) then - ignore (call ~log:true ["addif"; bridge; name]) + ignore (call ["addif"; bridge; name]) let destroy_port bridge name = if List.mem name (Sysfs.bridge_to_interfaces bridge) then - ignore (call ~log:true ["delif"; bridge; name]) + ignore (call ["delif"; bridge; name]) let set_forwarding_delay bridge time = - ignore (call ~log:true ["setfd"; bridge; string_of_int time]) + ignore (call ["setfd"; bridge; string_of_int time]) end module Ethtool = struct - let call ?(log=false) args = - call_script ~log_successful_output:log !ethtool args + let call args = + call_script !ethtool args let set_options name options = if options <> [] then - ignore (call ~log:true ("-s" :: name :: (List.concat (List.map (fun (k, v) -> [k; v]) options)))) + ignore (call ("-s" :: name :: (List.concat (List.map (fun (k, v) -> [k; v]) options)))) let set_offload name options = if options <> [] then - ignore (call ~log:true ("-K" :: name :: (List.concat (List.map (fun (k, v) -> [k; v]) options)))) + ignore (call ("-K" :: name :: (List.concat (List.map (fun (k, v) -> [k; v]) options)))) end module Dracut = struct - let call ?(log=false) args = - call_script ~timeout:(Some !dracut_timeout) ~log_successful_output:log !dracut args + let call args = + call_script ~timeout:(Some !dracut_timeout) !dracut args let rebuild_initrd () = try @@ -1341,8 +1341,8 @@ module Dracut = struct end module Modinfo = struct - let call ?(log=false) args = - call_script ~log_successful_output:log !modinfo args + let call args = + call_script !modinfo args let is_param_array driver param_name = try diff --git a/test/network_test_lacp_properties.ml b/test/network_test_lacp_properties.ml index c319554c1..0776888c9 100644 --- a/test/network_test_lacp_properties.ml +++ b/test/network_test_lacp_properties.ml @@ -70,7 +70,7 @@ let test_lacp_aggregation_key arg () = module OVS_Cli_test = struct include Ovs.Cli let vsctl_output = ref [] - let vsctl ?(log=true) args = + let vsctl args = vsctl_output := args ; String.concat " " args end From a9d1b906cc555db9cb1254be7ab74b0e12e60437 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 2 Oct 2018 14:56:29 +0100 Subject: [PATCH 197/260] Add customisable handler for script errors Signed-off-by: Rob Hoes --- lib/network_utils.ml | 43 +++++++++++++++++++++++-------------------- 1 file changed, 23 insertions(+), 20 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index d563e2e93..61d0714e9 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -60,7 +60,22 @@ let igmp_query_maxresp_time = ref "5000" let enable_ipv6_mcast_snooping = ref false let mcast_snooping_disable_flood_unregistered = ref true -let check_n_run run_func script args = +let default_error_handler script args stdout stderr status = + let message = + match status with + | Unix.WEXITED n -> Printf.sprintf "Exit code %d" n + | Unix.WSIGNALED s -> Printf.sprintf "Signaled %d" s (* Note that this is the internal ocaml signal number, see Sys module *) + | Unix.WSTOPPED s -> Printf.sprintf "Stopped %d" s + in + error "Call '%s %s' exited badly: %s [stdout = '%s'; stderr = '%s']" script + (String.concat " " args) message stdout stderr; + raise (Network_error (Script_error ["script", script; + "args", String.concat " " args; + "code", message; + "stdout", stdout; + "stderr", stderr])) + +let check_n_run ?(on_error=default_error_handler) run_func script args = try Unix.access script [ Unix.X_OK ]; (* Use the same $PATH as xapi *) @@ -72,34 +87,22 @@ let check_n_run run_func script args = error "Caught unix error: %s [%s, %s]" (Unix.error_message e) a b; error "Assuming script %s doesn't exist" script; raise (Network_error (Script_missing script)) - | Forkhelpers.Spawn_internal_error(stderr, stdout, e)-> - let message = - match e with - | Unix.WEXITED n -> Printf.sprintf "Exit code %d" n - | Unix.WSIGNALED s -> Printf.sprintf "Signaled %d" s (* Note that this is the internal ocaml signal number, see Sys module *) - | Unix.WSTOPPED s -> Printf.sprintf "Stopped %d" s - in - error "Call '%s %s' exited badly: %s [stdout = '%s'; stderr = '%s']" script - (String.concat " " args) message stdout stderr; - raise (Network_error (Script_error ["script", script; - "args", String.concat " " args; - "code", message; - "stdout", stdout; - "stderr", stderr])) - -let call_script ?(timeout=Some 60.0) script args = + | Forkhelpers.Spawn_internal_error(stderr, stdout, status)-> + on_error script args stdout stderr status + +let call_script ?(timeout=Some 60.0) ?on_error script args = let call_script_internal env script args = let (out,err) = Forkhelpers.execute_command_get_output ~env ?timeout script args in out in - check_n_run call_script_internal script args + check_n_run ?on_error call_script_internal script args -let fork_script script args = +let fork_script ?on_error script args = let fork_script_internal env script args = let pid = Forkhelpers.safe_close_and_exec ~env None None None [] script args in Forkhelpers.dontwaitpid pid; in - check_n_run fork_script_internal script args + check_n_run ?on_error fork_script_internal script args module Sysfs = struct let list () = From d4ce5787bf54f630bfe093838ef2a0cbd62ba63c Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 2 Oct 2018 14:57:18 +0100 Subject: [PATCH 198/260] Handle bridge-does-not-exist errors from OVS Avoid log spam, and raise the new Bridge_does_not_exist error. Signed-off-by: Rob Hoes --- lib/network_utils.ml | 28 +++++++++++++++++++++++++--- 1 file changed, 25 insertions(+), 3 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 61d0714e9..4e92e6b9b 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -905,6 +905,28 @@ module Proc = struct end module Ovs = struct + let match_multiple patterns s = + let rec loop = function + | [] -> None + | pattern :: rest -> + match Re.exec_opt pattern s with + | Some groups -> Some groups + | None -> loop rest + in + loop patterns + + let patterns = List.map Re.Perl.compile_pat [ + "no bridge named (.*)\n"; + "no row \"(.*)\" in table Bridge" + ] + + let error_handler script args stdout stderr exn = + match match_multiple patterns stderr with + | Some groups -> + let bridge = Re.Group.get groups 1 in + raise (Network_error (Bridge_does_not_exist bridge)) + | None -> + default_error_handler script args stdout stderr exn module Cli : sig val vsctl : string list -> string @@ -915,12 +937,12 @@ module Ovs = struct let s = Semaphore.create 5 let vsctl args = Semaphore.execute s (fun () -> - call_script ovs_vsctl ("--timeout=20" :: args) + call_script ~on_error:error_handler ovs_vsctl ("--timeout=20" :: args) ) let ofctl args = - call_script ovs_ofctl args + call_script ~on_error:error_handler ovs_ofctl args let appctl args = - call_script ovs_appctl args + call_script ~on_error:error_handler ovs_appctl args end module type Cli_S = module type of Cli From c1bf225585aac9a85d3b01863026856a0ed33bc1 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 2 Oct 2018 15:16:18 +0100 Subject: [PATCH 199/260] Do not log "get" commands To reduce the amount of spam in the logs, only log the commands that change something in the system (e.g. `ip addr add`) and not the ones that query something (e.g. `ip addr show`). We still log it if the command fails. Signed-off-by: Rob Hoes --- lib/network_utils.ml | 77 ++++++++++++++-------------- test/network_test_lacp_properties.ml | 2 +- 2 files changed, 39 insertions(+), 40 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 4e92e6b9b..4e768fd83 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -75,12 +75,13 @@ let default_error_handler script args stdout stderr status = "stdout", stdout; "stderr", stderr])) -let check_n_run ?(on_error=default_error_handler) run_func script args = +let check_n_run ?(on_error=default_error_handler) ?(log=true) run_func script args = try Unix.access script [ Unix.X_OK ]; (* Use the same $PATH as xapi *) let env = [| "PATH=" ^ (Sys.getenv "PATH") |] in - info "%s %s" script (String.concat " " args); + if log then + info "%s %s" script (String.concat " " args); run_func env script args with | Unix.Unix_error (e, a, b) -> @@ -90,19 +91,19 @@ let check_n_run ?(on_error=default_error_handler) run_func script args = | Forkhelpers.Spawn_internal_error(stderr, stdout, status)-> on_error script args stdout stderr status -let call_script ?(timeout=Some 60.0) ?on_error script args = +let call_script ?(timeout=Some 60.0) ?on_error ?log script args = let call_script_internal env script args = let (out,err) = Forkhelpers.execute_command_get_output ~env ?timeout script args in out in - check_n_run ?on_error call_script_internal script args + check_n_run ?on_error ?log call_script_internal script args -let fork_script ?on_error script args = +let fork_script ?on_error ?log script args = let fork_script_internal env script args = let pid = Forkhelpers.safe_close_and_exec ~env None None None [] script args in Forkhelpers.dontwaitpid pid; in - check_n_run ?on_error fork_script_internal script args + check_n_run ?on_error ?log fork_script_internal script args module Sysfs = struct let list () = @@ -357,19 +358,17 @@ module Ip = struct | V6 -> ["-6"] | V46 -> [] - let call args = - call_script iproute2 args + let call ?log args = + call_script ?log iproute2 args let find output attr = - info "Looking for %s in [%s]" attr output; let args = Astring.String.fields ~empty:false output in let indices = (Xapi_stdext_std.Listext.List.position (fun s -> s = attr) args) in - info "Found at [ %s ]" (String.concat ", " (List.map string_of_int indices)); List.map (fun i -> List.nth args (succ i)) indices let get_link_flags dev = Sysfs.assert_exists dev; - let output = call ["link"; "show"; "dev"; dev] in + let output = call ~log:false ["link"; "show"; "dev"; dev] in let i = String.index output '<' in let j = String.index output '>' in let flags = String.sub output (i + 1) (j - i - 1) in @@ -406,13 +405,13 @@ module Ip = struct let link ?(version=V46) dev attr = Sysfs.assert_exists dev; let v = string_of_version version in - let output = call (v @ ["link"; "show"; "dev"; dev]) in + let output = call ~log:false (v @ ["link"; "show"; "dev"; dev]) in find output attr let addr ?(version=V46) dev attr = Sysfs.assert_exists dev; let v = string_of_version version in - let output = call (v @ ["addr"; "show"; "dev"; dev]) in + let output = call ~log:false (v @ ["addr"; "show"; "dev"; dev]) in find output attr let get_mtu dev = @@ -517,7 +516,7 @@ module Ip = struct let route_show ?(version=V46) dev = let v = string_of_version version in - call (v @ ["route"; "show"; "dev"; dev]) + call ~log:false (v @ ["route"; "show"; "dev"; dev]) let set_route ?network dev gateway = try @@ -819,12 +818,12 @@ module Dhclient = struct end module Fcoe = struct - let call args = - call_script ~timeout:(Some 10.0) !fcoedriver args + let call ?log args = + call_script ?log ~timeout:(Some 10.0) !fcoedriver args let get_capabilities name = try - let output = call ["--xapi"; name; "capable"] in + let output = call ~log:false ["--xapi"; name; "capable"] in if Astring.String.is_infix ~affix:"True" output then ["fcoe"] else [] with _ -> debug "Failed to get fcoe support status on device %s" name; @@ -929,20 +928,20 @@ module Ovs = struct default_error_handler script args stdout stderr exn module Cli : sig - val vsctl : string list -> string - val ofctl : string list -> string - val appctl : string list -> string + val vsctl : ?log:bool -> string list -> string + val ofctl : ?log:bool -> string list -> string + val appctl : ?log:bool -> string list -> string end = struct open Xapi_stdext_threads let s = Semaphore.create 5 - let vsctl args = + let vsctl ?log args = Semaphore.execute s (fun () -> - call_script ~on_error:error_handler ovs_vsctl ("--timeout=20" :: args) + call_script ~on_error:error_handler ?log ovs_vsctl ("--timeout=20" :: args) ) - let ofctl args = - call_script ~on_error:error_handler ovs_ofctl args - let appctl args = - call_script ~on_error:error_handler ovs_appctl args + let ofctl ?log args = + call_script ~on_error:error_handler ?log ovs_ofctl args + let appctl ?log args = + call_script ~on_error:error_handler ?log ovs_appctl args end module type Cli_S = module type of Cli @@ -958,7 +957,7 @@ module Ovs = struct let raw_list = (Astring.String.cuts ~empty:false ~sep:"," (String.sub raw 1 (String.length raw - 2))) in let uuids = List.map (String.trim) raw_list in List.map (fun uuid -> - let raw = String.trim (vsctl ["get"; "interface"; uuid; "name"]) in + let raw = String.trim (vsctl ~log:false ["get"; "interface"; uuid; "name"]) in String.sub raw 1 (String.length raw - 2)) uuids else [] @@ -966,7 +965,7 @@ module Ovs = struct let bridge_to_ports name = try - let ports = String.trim (vsctl ["list-ports"; name]) in + let ports = String.trim (vsctl ~log:false ["list-ports"; name]) in let ports' = if ports <> "" then Astring.String.cuts ~empty:false ~sep:"\n" ports @@ -978,7 +977,7 @@ module Ovs = struct let bridge_to_interfaces name = try - let ifaces = String.trim (vsctl ["list-ifaces"; name]) in + let ifaces = String.trim (vsctl ~log:false ["list-ifaces"; name]) in if ifaces <> "" then Astring.String.cuts ~empty:false ~sep:"\n" ifaces else @@ -987,8 +986,8 @@ module Ovs = struct let bridge_to_vlan name = try - let parent = vsctl ["br-to-parent"; name] |> String.trim in - let vlan = vsctl ["br-to-vlan"; name] |> String.trim |> int_of_string in + let parent = vsctl ~log:false ["br-to-parent"; name] |> String.trim in + let vlan = vsctl ~log:false ["br-to-vlan"; name] |> String.trim |> int_of_string in Some (parent, vlan) with e -> debug "bridge_to_vlan: %s" (Printexc.to_string e); @@ -1001,7 +1000,7 @@ module Ovs = struct let get_bond_link_status name = try - let raw = appctl ["bond/show"; name] in + let raw = appctl ~log:false ["bond/show"; name] in let lines = Astring.String.cuts ~empty:false ~sep:"\n" raw in List.fold_left (fun (slaves, active_slave) line -> let slaves = @@ -1027,7 +1026,7 @@ module Ovs = struct let get_bond_mode name = try - let output = String.trim (vsctl ["get"; "port"; name; "bond_mode"]) in + let output = String.trim (vsctl ~log:false ["get"; "port"; name; "bond_mode"]) in if output <> "[]" then Some output else None with _ -> None @@ -1076,7 +1075,7 @@ module Ovs = struct let get_vlans name = try let vlans_with_uuid = - let raw = vsctl ["--bare"; "-f"; "table"; "--"; "--columns=name,_uuid"; "find"; "port"; "fake_bridge=true"] in + let raw = vsctl ~log:false ["--bare"; "-f"; "table"; "--"; "--columns=name,_uuid"; "find"; "port"; "fake_bridge=true"] in if raw <> "" then let lines = Astring.String.cuts ~empty:false ~sep:"\n" (String.trim raw) in List.map (fun line -> Scanf.sscanf line "%s %s" (fun a b-> a, b)) lines @@ -1084,7 +1083,7 @@ module Ovs = struct [] in let bridge_ports = - let raw = vsctl ["get"; "bridge"; name; "ports"] in + let raw = vsctl ~log:false ["get"; "bridge"; name; "ports"] in let raw = String.trim raw in if raw <> "[]" then let raw_list = (Astring.String.cuts ~empty:false ~sep:"," (String.sub raw 1 (String.length raw - 2))) in @@ -1106,7 +1105,7 @@ module Ovs = struct let get_mcast_snooping_enable ~name = try - vsctl ["--"; "get"; "bridge"; name; "mcast_snooping_enable"] + vsctl ~log:false ["--"; "get"; "bridge"; name; "mcast_snooping_enable"] |> String.trim |> bool_of_string with _ -> false @@ -1190,7 +1189,7 @@ module Ovs = struct vsctl ["--"; "--if-exists"; "del-br"; name] let list_bridges () = - let bridges = String.trim (vsctl ["list-br"]) in + let bridges = String.trim (vsctl ~log:false ["list-br"]) in if bridges <> "" then Astring.String.cuts ~empty:false ~sep:"\n" bridges else @@ -1205,7 +1204,7 @@ module Ovs = struct vsctl ["--"; "--with-iface"; "--if-exists"; "del-port"; name] let port_to_bridge name = - vsctl ["port-to-br"; name] + vsctl ~log:false ["port-to-br"; name] let make_bond_properties name properties = let known_props = ["mode"; "hashing-algorithm"; "updelay"; "downdelay"; @@ -1285,7 +1284,7 @@ module Ovs = struct mac_args @ args @ per_iface_args) let get_fail_mode bridge = - vsctl ["get-fail-mode"; bridge] + vsctl ~log:false ["get-fail-mode"; bridge] let add_default_flows bridge mac interfaces = let ports = List.map (fun interface -> vsctl ["get"; "interface"; interface; "ofport"]) interfaces in diff --git a/test/network_test_lacp_properties.ml b/test/network_test_lacp_properties.ml index 0776888c9..ef2ab0366 100644 --- a/test/network_test_lacp_properties.ml +++ b/test/network_test_lacp_properties.ml @@ -70,7 +70,7 @@ let test_lacp_aggregation_key arg () = module OVS_Cli_test = struct include Ovs.Cli let vsctl_output = ref [] - let vsctl args = + let vsctl ?log args = vsctl_output := args ; String.concat " " args end From 50d245cd84c042d283da3e27fa7a61756f291085 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 2 Oct 2018 15:46:57 +0100 Subject: [PATCH 200/260] Do not apply IPv6 config if IPv6 is disabled Any exceptions from this were ignored anyway, but this again avoids scary messages in the logs. Signed-off-by: Rob Hoes --- lib/network_utils.ml | 7 +++++++ networkd/network_server.ml | 8 ++++++++ 2 files changed, 15 insertions(+) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 4e768fd83..9d89f6888 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -901,6 +901,13 @@ module Proc = struct let get_bond_links_up name = let statusses = get_bond_slave_info name "MII Status" in List.fold_left (fun x (_, y) -> x + (if y = "up" then 1 else 0)) 0 statusses + + let get_ipv6_disabled () = + try + Unixext.string_of_file "/proc/sys/net/ipv6/conf/all/disable_ipv6" + |> String.trim + |> (=) "1" + with _ -> false end module Ovs = struct diff --git a/networkd/network_server.ml b/networkd/network_server.ml index e64295277..0ce2c3fe8 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -323,6 +323,9 @@ module Interface = struct let set_ipv6_conf _ dbg ~name ~conf = Debug.with_thread_associated dbg (fun () -> + if Proc.get_ipv6_disabled () then + warn "Not configuring IPv6 address for %s (IPv6 is disabled)" name + else begin debug "Configuring IPv6 address for %s: %s" name (conf |> Rpcmarshal.marshal typ_of_ipv6 |> Jsonrpc.to_string); update_config name {(get_config name) with ipv6_conf = conf}; match conf with @@ -371,6 +374,7 @@ module Interface = struct let add_addrs = Xapi_stdext_std.Listext.List.set_difference addrs cur_addrs in List.iter (Ip.del_ip_addr name) rm_addrs; List.iter (Ip.set_ip_addr name) add_addrs + end ) () let get_ipv6_gateway _ dbg ~name = @@ -385,6 +389,9 @@ module Interface = struct let set_ipv6_gateway _ dbg ~name ~address = Debug.with_thread_associated dbg (fun () -> + if Proc.get_ipv6_disabled () then + warn "Not configuring IPv6 gateway for %s (IPv6 is disabled)" name + else begin debug "Configuring IPv6 gateway for %s: %s" name (Unix.string_of_inet_addr address); update_config name {(get_config name) with ipv6_gateway = Some address}; if !config.gateway_interface = None || !config.gateway_interface = Some name then begin @@ -392,6 +399,7 @@ module Interface = struct Ip.set_gateway name address end else debug "%s is NOT the default gateway interface" name + end ) () let set_ipv4_routes _ dbg ~name ~routes = From dacf5b42c2bb83cdf58a0b770b234639fd6c7d25 Mon Sep 17 00:00:00 2001 From: Yang Qian Date: Mon, 8 Oct 2018 17:56:58 +0800 Subject: [PATCH 201/260] Refine SR-IOV log Signed-off-by: Yang Qian --- networkd/network_server.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 0ce2c3fe8..6435d8891 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -141,12 +141,13 @@ module Sriov = struct if is_support then ["sriov"] else [] let config_sriov ~enable dev = + let op = if enable then "enable" else "disable" in let open Rresult.R.Infix in Sysfs.get_driver_name_err dev >>= fun driver -> let config = Modprobe.get_config_from_comments driver in match Modprobe.get_vf_param config with | Some vf_param -> - debug "enable SR-IOV on a device: %s via modprobe" dev; + debug "%s SR-IOV on a device: %s via modprobe" op dev; (if enable then Modprobe.get_maxvfs driver config else Ok 0) >>= fun numvfs -> (* CA-287340: Even if the current numvfs equals to the target numvfs, it is still needed to update SR-IOV modprobe config file, as the @@ -158,7 +159,7 @@ module Sriov = struct else Ok Modprobe_successful_requires_reboot | None -> - debug "enable SR-IOV on a device: %s via sysfs" dev; + debug "%s SR-IOV on a device: %s via sysfs" op dev; begin if enable then Sysfs.get_sriov_maxvfs dev else Sysfs.unbind_child_vfs dev >>= fun () -> Ok 0 From f89ecbb9f8a0c37e447233b678323988ef0e7485 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Thu, 8 Nov 2018 11:47:36 +0000 Subject: [PATCH 202/260] New ocaml-rpc Signed-off-by: Jon Ludlam --- networkd/network_server.ml | 2 +- networkd/networkd.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 6435d8891..08c4c159a 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -18,7 +18,7 @@ open Xapi_stdext_std open Xapi_stdext_unix open Xapi_stdext_monadic -module S = Network_interface.Interface_API(Idl.GenServerExn ()) +module S = Network_interface.Interface_API(Idl.Exn.GenServer ()) module D = Debug.Make(struct let name = "network_server" end) open D diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 2eae91794..6393d850f 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -152,7 +152,7 @@ let _ = let server = Xcp_service.make ~path:!Network_interface.default_path ~queue_name:!Network_interface.queue_name - ~rpc_fn:(Idl.server Network_server.S.implementation) + ~rpc_fn:(Idl.Exn.server Network_server.S.implementation) () in Xcp_service.maybe_daemonize ~start_fn:(fun () -> From 309884aed1c2de81ad39a7029292d67bb7445462 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Thu, 29 Nov 2018 09:56:43 +0000 Subject: [PATCH 203/260] CA-303529/CA-287657: Immediately setup management on first boot Since we put in support for management-on-VLAN, setting up the management IP address on first boot has been a little different. In the past, xcp-networkd would set this up immediately by taking the configuration from the MANAGEMENT_INTERFACE key in the inventory, and the management.conf file in the first-boot data, both written by the host installer. Then, we changed the host installer to no longer write the MANAGEMENT_INTERFACE key, because we do not have a deterministic name for VLAN bridges: the management bridge name becomes know only once the first-boot scripts run. Besides, it is good to not have this naming policy encoded in the host installer as well as in the Toolstack. The startup sequence of xcp-networkd was changed to not configure anything in this case, and instead wait for xapi and the first-boot scripts. This mean that, on first boot, the management IP address was set much later than before. Unfortunately, there are services that run at host boot time, such as ntpdate, that do not cope with this very well. This commit changes back to the old behaviour, where xcp-networkd immediately configures the network on first boot, by having it derive the bridge name itself. For the non-VLAN case, this is easy, because of the deterministic naming policy. For the VLAN case, a bridge with a temporary name is created, which is later replaced by xapi once the first-boot scripts run. This is in fact the same as what happens during an emergency network reset (see xe-reset-networking). Signed-off-by: Rob Hoes --- lib/network_config.ml | 56 +++++++++++++++++++++++++++---------------- 1 file changed, 36 insertions(+), 20 deletions(-) diff --git a/lib/network_config.ml b/lib/network_config.ml index 0b4f35669..b41423eb6 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -42,8 +42,28 @@ let read_management_conf () = let device = List.assoc "LABEL" args in let vlan = if List.mem_assoc "VLAN" args then Some (List.assoc "VLAN" args) else None in Inventory.reread_inventory (); - let bridge_name = Inventory.lookup Inventory._management_interface in - debug "Management bridge in inventory file: %s" bridge_name; + let bridge_name = + let inventory_bridge = + try Some (Inventory.lookup Inventory._management_interface) + with Inventory.Missing_inventory_key _ -> None + in + match inventory_bridge with + | Some "" | None -> + let bridge = + if vlan = None then + bridge_naming_convention device + else + (* At this point, we don't know what the VLAN bridge name will be, + * so use a temporary name. Xapi will replace the bridge once the name + * has been decided on. *) + "xentemp" + in + debug "No management bridge in inventory file... using %s" bridge; + bridge + | Some bridge -> + debug "Management bridge in inventory file: %s" bridge; + bridge + in let mac = Network_utils.Ip.get_mac device in let ipv4_conf, ipv4_gateway, dns = match List.assoc "MODE" args with @@ -78,24 +98,20 @@ let read_management_conf () = ports = [device, {default_port with interfaces = [device]}]; persistent_b = true } in - if bridge_name = "" then - [], [] - else begin - match vlan with - | None -> - [device, phy_interface; bridge_name, bridge_interface], - [bridge_name, primary_bridge_conf] - | Some vlan -> - let parent = bridge_naming_convention device in - let secondary_bridge_conf = {default_bridge with - vlan = Some (parent, int_of_string vlan); - bridge_mac = (Some mac); - persistent_b = true - } in - let parent_bridge_interface = {default_interface with persistent_i = true} in - [device, phy_interface; parent, parent_bridge_interface; bridge_name, bridge_interface], - [parent, primary_bridge_conf; bridge_name, secondary_bridge_conf] - end + match vlan with + | None -> + [device, phy_interface; bridge_name, bridge_interface], + [bridge_name, primary_bridge_conf] + | Some vlan -> + let parent = bridge_naming_convention device in + let secondary_bridge_conf = {default_bridge with + vlan = Some (parent, int_of_string vlan); + bridge_mac = (Some mac); + persistent_b = true + } in + let parent_bridge_interface = {default_interface with persistent_i = true} in + [device, phy_interface; parent, parent_bridge_interface; bridge_name, bridge_interface], + [parent, primary_bridge_conf; bridge_name, secondary_bridge_conf] in {interface_config = interface_config; bridge_config = bridge_config; gateway_interface = Some bridge_name; dns_interface = Some bridge_name} From a41bf487d5257a7ea55cedaa1765eb2ee33535c4 Mon Sep 17 00:00:00 2001 From: Konstantina Chremmou Date: Fri, 30 Nov 2018 10:09:40 +0000 Subject: [PATCH 204/260] Moved from jbuilder to dune and deprecated xcp and xcp-inventory in favour of xapi-idl and xapi-invenotry respectively. Signed-off-by: Konstantina Chremmou --- .merlin | 21 ------------------- Makefile | 10 ++++----- dune-project | 1 + jbuild | 1 - lib/dune | 18 ++++++++++++++++ lib/jbuild | 19 ----------------- networkd/dune | 40 +++++++++++++++++++++++++++++++++++ networkd/jbuild | 43 -------------------------------------- networkd_db/dune | 12 +++++++++++ networkd_db/jbuild | 12 ----------- profiling/{jbuild => dune} | 5 +---- test/dune | 17 +++++++++++++++ test/jbuild | 16 -------------- xapi-networkd.opam | 29 ++++++++++++------------- 14 files changed, 109 insertions(+), 135 deletions(-) delete mode 100644 .merlin create mode 100644 dune-project delete mode 100644 jbuild create mode 100644 lib/dune delete mode 100644 lib/jbuild create mode 100644 networkd/dune delete mode 100644 networkd/jbuild create mode 100644 networkd_db/dune delete mode 100644 networkd_db/jbuild rename profiling/{jbuild => dune} (63%) create mode 100644 test/dune delete mode 100644 test/jbuild diff --git a/.merlin b/.merlin deleted file mode 100644 index 0ef04d82c..000000000 --- a/.merlin +++ /dev/null @@ -1,21 +0,0 @@ -S lib -S networkd -S networkd_db -S test -S profiling -B _build/profiling -B _build/lib -B _build/networkd -PKG forkexec -PKG rpclib -PKG stdext -PKG stdext -PKG threads -PKG unix -PKG xcp -PKG xcp-inventory -PKG xcp.network -PKG xcp.network -PKG xen-api-client -PKG oUnit -PKG bisect_ppx.runtime diff --git a/Makefile b/Makefile index c355d163a..4171e2243 100644 --- a/Makefile +++ b/Makefile @@ -5,10 +5,10 @@ MANDIR ?= /usr/share/man/man1 .PHONY: release build install uninstall clean test doc reindent release: - jbuilder build @install @networkd/man + dune build @install @networkd/man --profile=release build: - jbuilder build @install @networkd/man --dev + dune build @install @networkd/man install: mkdir -p $(DESTDIR)$(SBINDIR) @@ -24,14 +24,14 @@ uninstall: rm -f $(DESTDIR)$(SBINDIR)/networkd_db clean: - jbuilder clean + dune clean test: - jbuilder runtest + dune runtest --profile=release # requires odoc doc: - jbuilder build @doc + dune build @doc --profile=release reindent: ocp-indent --inplace **/*.ml* diff --git a/dune-project b/dune-project new file mode 100644 index 000000000..f9337290c --- /dev/null +++ b/dune-project @@ -0,0 +1 @@ +(lang dune 1.4) diff --git a/jbuild b/jbuild deleted file mode 100644 index 265ed0a0a..000000000 --- a/jbuild +++ /dev/null @@ -1 +0,0 @@ -(jbuild_version 1) \ No newline at end of file diff --git a/lib/dune b/lib/dune new file mode 100644 index 000000000..0f093a58a --- /dev/null +++ b/lib/dune @@ -0,0 +1,18 @@ +(library + (name networklibs) + (flags (:standard :standard -bin-annot -safe-string)) + (libraries + astring + forkexec + mtime + mtime.clock.os + rpclib + systemd + threads + re.perl + xapi-stdext-unix + xapi-inventory + xapi-idl.network + ) + (wrapped false) +) diff --git a/lib/jbuild b/lib/jbuild deleted file mode 100644 index 0a93d5a32..000000000 --- a/lib/jbuild +++ /dev/null @@ -1,19 +0,0 @@ -(jbuild_version 1) - -(library - ((name networklibs) - (flags (:standard :standard -bin-annot -safe-string)) - (libraries (astring - forkexec - mtime - mtime.clock.os - rpclib - systemd - threads - re.perl - xapi-stdext-unix - xcp-inventory - xcp.network)) - (wrapped false) - ) -) diff --git a/networkd/dune b/networkd/dune new file mode 100644 index 000000000..b1869336d --- /dev/null +++ b/networkd/dune @@ -0,0 +1,40 @@ +(rule + (targets version.ml) + (deps ../VERSION) + (action (with-stdout-to %{targets} (bash "cat %{deps} | sed s/^/\"let version = \"\\\"/ | sed s/$/\\\"/"))) +) + +(rule + (targets xcp-networkd.1) + (deps networkd.exe) + (action (with-stdout-to %{targets} (run %{deps} "--help=groff"))) +) + +(executable + (name networkd) + (public_name xapi-networkd) + (package xapi-networkd) + (flags (:standard -bin-annot -safe-string)) + (libraries + forkexec + netlink + networklibs + profiling + rpclib + systemd + threads + xapi-stdext-monadic + xapi-stdext-pervasives + xapi-stdext-threads + xapi-stdext-unix + xapi-inventory + xapi-idl + xapi-idl.network + xen-api-client + ) +) + +(alias + (name man) + (deps xcp-networkd.1) +) diff --git a/networkd/jbuild b/networkd/jbuild deleted file mode 100644 index 427f78d96..000000000 --- a/networkd/jbuild +++ /dev/null @@ -1,43 +0,0 @@ -(rule - ((targets (version.ml)) - (deps (../VERSION)) - (action (with-stdout-to ${@} (bash "cat ${<} | sed s/^/\"let version = \"\\\"/ | sed s/$/\\\"/"))) - ) -) - -(rule - ((targets (xcp-networkd.1)) - (deps (networkd.exe)) - (action (with-stdout-to ${@} (run ${<} "--help=groff"))) - ) -) - -(executable - ((name networkd) - (public_name xapi-networkd) - (package xapi-networkd) - (flags (:standard -bin-annot -safe-string)) - (libraries (forkexec - netlink - networklibs - profiling - rpclib - systemd - threads - xapi-stdext-monadic - xapi-stdext-pervasives - xapi-stdext-threads - xapi-stdext-unix - xcp-inventory - xcp - xcp.network - xen-api-client) - ) - ) -) - -(alias - ((name man) - (deps (xcp-networkd.1)) - ) -) diff --git a/networkd_db/dune b/networkd_db/dune new file mode 100644 index 000000000..8c4e8479e --- /dev/null +++ b/networkd_db/dune @@ -0,0 +1,12 @@ +(executable + (name networkd_db) + (public_name networkd_db) + (package xapi-networkd) + (flags (:standard -bin-annot -safe-string)) + (libraries + networklibs + profiling + threads + xapi-idl.network + ) +) \ No newline at end of file diff --git a/networkd_db/jbuild b/networkd_db/jbuild deleted file mode 100644 index 0ff324a83..000000000 --- a/networkd_db/jbuild +++ /dev/null @@ -1,12 +0,0 @@ -(executable - ((name networkd_db) - (public_name networkd_db) - (package xapi-networkd) - (flags (:standard -bin-annot -safe-string)) - (libraries (networklibs - profiling - threads - xcp.network) - ) - ) -) \ No newline at end of file diff --git a/profiling/jbuild b/profiling/dune similarity index 63% rename from profiling/jbuild rename to profiling/dune index 2115356d3..bd2594c81 100644 --- a/profiling/jbuild +++ b/profiling/dune @@ -1,8 +1,5 @@ -(jbuild_version 1) - (library - ((name profiling) + (name profiling) (flags (:standard -bin-annot -safe-string)) (wrapped false) - ) ) \ No newline at end of file diff --git a/test/dune b/test/dune new file mode 100644 index 000000000..c3675a449 --- /dev/null +++ b/test/dune @@ -0,0 +1,17 @@ +(executable + (name network_test) + (flags (:standard -bin-annot -safe-string)) + (libraries + astring + networklibs + oUnit + profiling + xapi-test-utils + ) +) + +(alias + (name runtest) + (deps (:x network_test.exe) (source_tree jsonrpc_files)) + (action (chdir ../ (run %{x}))) +) diff --git a/test/jbuild b/test/jbuild deleted file mode 100644 index afc6f370d..000000000 --- a/test/jbuild +++ /dev/null @@ -1,16 +0,0 @@ -(executable - ((name network_test) - (flags (:standard -bin-annot -safe-string)) - (libraries (astring - networklibs - oUnit - profiling - xapi-test-utils) - ) - ) -) - -(alias - ((name runtest) - (deps (network_test.exe (files_recursively_in jsonrpc_files))) - (action (chdir ../ (run ${<}))))) diff --git a/xapi-networkd.opam b/xapi-networkd.opam index 2fce2fc60..82590549b 100644 --- a/xapi-networkd.opam +++ b/xapi-networkd.opam @@ -1,16 +1,16 @@ -opam-version: "1" +opam-version: "2.0" maintainer: "jonathan.ludlam@eu.citrix.com" - +authors: "jonathan.ludlam@eu.citrix.com" +homepage: "https://github.com/xapi-project/xcp-networkd" +dev-repo: "git+https://github.com/xapi-project/xcp-networkd.git" +bug-reports: "https://github.com/xapi-project/xcp-networkd/issues" build: [ - "jbuilder" "build" "-p" name "-j" jobs + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name] {with-test} ] - -build-test: ["jbuilder" "runtest" "-p" name] - depends: [ - "jbuilder" {build} - "astring" - "mtime" + "ocaml" + "dune" {build} "netlink" "rpc" "systemd" @@ -18,10 +18,11 @@ depends: [ "xapi-idl" "xapi-inventory" "xapi-libs-transitional" - "xapi-stdext-monadic" - "xapi-stdext-pervasives" - "xapi-stdext-std" - "xapi-stdext-threads" - "xapi-stdext-unix" + "xapi-stdext" {>= "3.0.0"} "xen-api-client" ] +synopsis: "The XCP networking daemon" +url { + src: + "https://github.com/xapi-project/xcp-networkd/archive/master/master.tar.gz" +} \ No newline at end of file From cf78286369ae7c41f5c6611e33447cf9c90b38a8 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Tue, 4 Dec 2018 15:48:52 +0000 Subject: [PATCH 205/260] CP-27898 clean up Makefile Signed-off-by: Christian Lindig --- Makefile | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/Makefile b/Makefile index 4171e2243..c0b821066 100644 --- a/Makefile +++ b/Makefile @@ -1,14 +1,17 @@ BINDIR ?= /usr/bin SBINDIR ?= /usr/sbin MANDIR ?= /usr/share/man/man1 +JOBS = $(shell getconf _NPROCESSORS_ONLN) +PROFILE=release + .PHONY: release build install uninstall clean test doc reindent release: - dune build @install @networkd/man --profile=release + dune build @install @networkd/man --profile=$(PROFILE) -j $(JOBS) build: - dune build @install @networkd/man + dune build @install @networkd/man -j $(JOBS) install: mkdir -p $(DESTDIR)$(SBINDIR) @@ -27,11 +30,11 @@ clean: dune clean test: - dune runtest --profile=release + dune runtest --profile=$(PROFIE) # requires odoc doc: - dune build @doc --profile=release + dune build @doc --profile=$(PROFILE) reindent: ocp-indent --inplace **/*.ml* From 8aad95237fbd004f47778f18f60f1a31b5e4ec67 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Tue, 4 Dec 2018 15:49:09 +0000 Subject: [PATCH 206/260] CP-27898 clean up dune files Signed-off-by: Christian Lindig --- lib/dune | 19 +++--------------- networkd/dune | 51 +++++++++++++++++++++--------------------------- networkd_db/dune | 16 +++++---------- profiling/dune | 7 +++---- test/dune | 25 ++++++++++++------------ 5 files changed, 46 insertions(+), 72 deletions(-) diff --git a/lib/dune b/lib/dune index 0f093a58a..341cb6245 100644 --- a/lib/dune +++ b/lib/dune @@ -1,18 +1,5 @@ (library - (name networklibs) - (flags (:standard :standard -bin-annot -safe-string)) - (libraries - astring - forkexec - mtime - mtime.clock.os - rpclib - systemd - threads - re.perl - xapi-stdext-unix - xapi-inventory - xapi-idl.network - ) - (wrapped false) + (name networklibs) + (libraries astring forkexec mtime mtime.clock.os rpclib systemd threads re.perl xapi-stdext-unix xapi-inventory xapi-idl.network) + (wrapped false) ) diff --git a/networkd/dune b/networkd/dune index b1869336d..67526d132 100644 --- a/networkd/dune +++ b/networkd/dune @@ -1,40 +1,33 @@ (rule - (targets version.ml) - (deps ../VERSION) - (action (with-stdout-to %{targets} (bash "cat %{deps} | sed s/^/\"let version = \"\\\"/ | sed s/$/\\\"/"))) + (targets version.ml) + (deps ../VERSION) + (action + (with-stdout-to + %{targets} + (bash "cat %{deps} | sed s/^/\"let version = \"\\\"/ | sed s/$/\\\"/") + ) + ) ) (rule - (targets xcp-networkd.1) - (deps networkd.exe) - (action (with-stdout-to %{targets} (run %{deps} "--help=groff"))) + (targets xcp-networkd.1) + (deps networkd.exe) + (action + (with-stdout-to + %{targets} + (run %{deps} "--help=groff") + ) + ) ) (executable - (name networkd) - (public_name xapi-networkd) - (package xapi-networkd) - (flags (:standard -bin-annot -safe-string)) - (libraries - forkexec - netlink - networklibs - profiling - rpclib - systemd - threads - xapi-stdext-monadic - xapi-stdext-pervasives - xapi-stdext-threads - xapi-stdext-unix - xapi-inventory - xapi-idl - xapi-idl.network - xen-api-client - ) + (name networkd) + (public_name xapi-networkd) + (package xapi-networkd) + (libraries forkexec netlink networklibs profiling rpclib systemd threads xapi-stdext-monadic xapi-stdext-pervasives xapi-stdext-threads xapi-stdext-unix xapi-inventory xapi-idl xapi-idl.network xen-api-client) ) (alias - (name man) - (deps xcp-networkd.1) + (name man) + (deps xcp-networkd.1) ) diff --git a/networkd_db/dune b/networkd_db/dune index 8c4e8479e..9b3c4a2e1 100644 --- a/networkd_db/dune +++ b/networkd_db/dune @@ -1,12 +1,6 @@ (executable - (name networkd_db) - (public_name networkd_db) - (package xapi-networkd) - (flags (:standard -bin-annot -safe-string)) - (libraries - networklibs - profiling - threads - xapi-idl.network - ) -) \ No newline at end of file + (name networkd_db) + (public_name networkd_db) + (package xapi-networkd) + (libraries networklibs profiling threads xapi-idl.network) +) diff --git a/profiling/dune b/profiling/dune index bd2594c81..75a332b26 100644 --- a/profiling/dune +++ b/profiling/dune @@ -1,5 +1,4 @@ (library - (name profiling) - (flags (:standard -bin-annot -safe-string)) - (wrapped false) -) \ No newline at end of file + (name profiling) + (wrapped false) +) diff --git a/test/dune b/test/dune index c3675a449..9c06421cc 100644 --- a/test/dune +++ b/test/dune @@ -1,17 +1,18 @@ (executable - (name network_test) - (flags (:standard -bin-annot -safe-string)) - (libraries - astring - networklibs - oUnit - profiling - xapi-test-utils - ) + (name network_test) + (libraries astring networklibs oUnit profiling xapi-test-utils) ) (alias - (name runtest) - (deps (:x network_test.exe) (source_tree jsonrpc_files)) - (action (chdir ../ (run %{x}))) + (name runtest) + (deps + (:x network_test.exe) + (source_tree jsonrpc_files) + ) + (action + (chdir + ../ + (run %{x}) + ) + ) ) From 9ebf9829737e10735d5f484ed088daecf2b7eee9 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Tue, 4 Dec 2018 16:13:34 +0000 Subject: [PATCH 207/260] CP-27898 Remove warnings with PROFILE=dev Signed-off-by: Christian Lindig --- lib/jsonrpc_client.mli | 1 + lib/network_config.ml | 2 +- lib/network_utils.ml | 23 +++++++------- networkd/network_monitor.ml | 1 - networkd/network_monitor_thread.ml | 11 ++++--- networkd/network_server.ml | 51 +++++++++++++++--------------- networkd/networkd.ml | 5 --- networkd_db/networkd_db.ml | 2 +- 8 files changed, 45 insertions(+), 51 deletions(-) diff --git a/lib/jsonrpc_client.mli b/lib/jsonrpc_client.mli index c0e40ca06..ad785ad83 100644 --- a/lib/jsonrpc_client.mli +++ b/lib/jsonrpc_client.mli @@ -20,6 +20,7 @@ val json_rpc_read_timeout : int64 ref val json_rpc_write_timeout : int64 ref val timeout_read : Unix.file_descr -> int64 -> string + (** Do an JSON-RPC call to a server that is listening on a Unix domain * socket at the given path. *) val with_rpc : ?version:Jsonrpc.version -> path:string -> call:Rpc.call -> unit -> Rpc.response diff --git a/lib/network_config.ml b/lib/network_config.ml index b41423eb6..ececc3973 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -65,7 +65,7 @@ let read_management_conf () = bridge in let mac = Network_utils.Ip.get_mac device in - let ipv4_conf, ipv4_gateway, dns = + let ipv4_conf, ipv4_gateway, _dns = match List.assoc "MODE" args with | "static" -> let ip = List.assoc "IP" args |> Unix.inet_addr_of_string in diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 9d89f6888..6a1381469 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -14,7 +14,6 @@ open Xapi_stdext_pervasives open Xapi_stdext_unix -open Xapi_stdext_std open Network_interface module D = Debug.Make(struct let name = "network_utils" end) @@ -93,7 +92,7 @@ let check_n_run ?(on_error=default_error_handler) ?(log=true) run_func script ar let call_script ?(timeout=Some 60.0) ?on_error ?log script args = let call_script_internal env script args = - let (out,err) = Forkhelpers.execute_command_get_output ~env ?timeout script args in + let (out,_err) = Forkhelpers.execute_command_get_output ~env ?timeout script args in out in check_n_run ?on_error ?log call_script_internal script args @@ -155,7 +154,7 @@ module Sysfs = struct try output_string outchan (l ^ "\n"); close_out outchan - with exn -> close_out outchan; raise (Network_error (Write_error file)) + with _ -> close_out outchan; raise (Network_error (Write_error file)) let is_physical name = try @@ -175,7 +174,7 @@ module Sysfs = struct try let devpath = Unix.readlink (getpath name "device") in List.hd (List.rev (Astring.String.cuts ~empty:false ~sep:"/" devpath)) - with exn -> "N/A" + with _ -> "N/A" let get_pci_ids name = let read_id_from path = @@ -193,7 +192,7 @@ module Sysfs = struct try let driver_path = Unix.readlink (getpath dev "device/driver") in match Astring.String.cut ~sep:"/" ~rev:true driver_path with - | Some (prefix, suffix) -> Some suffix + | Some (_prefix, suffix) -> Some suffix | None -> debug "get %s driver name: %s does not contain slash" dev driver_path; None @@ -748,7 +747,7 @@ module Dhclient = struct let ipv6' = if ipv6 then "6" else "" in Filename.concat "/var/lib/xcp" (Printf.sprintf "dhclient%s-%s.conf" ipv6' interface) - let generate_conf ?(ipv6=false) interface options = + let[@warning "-27"] generate_conf ?(ipv6=false) interface options = let minimal = ["subnet-mask"; "broadcast-address"; "time-offset"; "host-name"; "nis-domain"; "nis-servers"; "ntp-servers"; "interface-mtu"] in let set_gateway = @@ -874,7 +873,7 @@ module Proc = struct loop None [] lines in check_lines lines - with e -> + with _ -> error "Error: could not read %s." (bonding_dir ^ name); [] @@ -894,7 +893,7 @@ module Proc = struct with _ -> vlans ) [] "/proc/net/vlan/config" - with e -> + with _ -> error "Error: could not read /proc/net/vlan/config"; [] @@ -1002,7 +1001,7 @@ module Ovs = struct let get_real_bridge name = match bridge_to_vlan name with - | Some (parent, vlan) -> parent + | Some (parent, _vlan) -> parent | None -> name let get_bond_link_status name = @@ -1119,7 +1118,7 @@ module Ovs = struct let inject_igmp_query ~name = try - let vvifs = get_bridge_vlan_vifs name in + let vvifs = get_bridge_vlan_vifs ~name in let bvifs = bridge_to_interfaces name in let bvifs' = List.filter (fun vif -> Astring.String.is_prefix ~affix:"vif" vif) bvifs in (* The vifs may be large. However considering current XS limit of 1000VM*7NIC/VM + 800VLANs, the buffer of CLI should be sufficient for lots of vifxxxx.xx *) @@ -1422,7 +1421,7 @@ module Modprobe = struct let get_config_from_comments driver = try let open Xapi_stdext_std.Listext in - Unixext.read_lines (getpath driver) + Unixext.read_lines ~path:(getpath driver) |> List.filter_map (fun x -> let line = String.trim x in if not (Astring.String.is_prefix ~affix:("# ") line) @@ -1501,7 +1500,7 @@ module Modprobe = struct else trimed_s in - let lines = try Unixext.read_lines (getpath driver) with _ -> [] in + let lines = try Unixext.read_lines ~path:(getpath driver) with _ -> [] in let new_conf = List.map parse_single_line lines in match !has_probe_conf, !need_rebuild_initrd with | true, true -> diff --git a/networkd/network_monitor.ml b/networkd/network_monitor.ml index 15dc02eb4..a894fcfc3 100644 --- a/networkd/network_monitor.ml +++ b/networkd/network_monitor.ml @@ -12,7 +12,6 @@ * GNU Lesser General Public License for more details. *) -open Network_interface include Network_stats let write_stats stats = diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index e238299f5..d460ef246 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -32,7 +32,7 @@ let xapi_rpc xml = let open Xmlrpc_client in XMLRPC_protocol.rpc ~srcstr:"xcp-networkd" ~dststr:"xapi" ~transport:(Unix "/var/xapi/xapi") ~http:(xmlrpc ~version:"1.0" "/") xml -let send_bond_change_alert dev interfaces message = +let send_bond_change_alert _dev interfaces message = let ifaces = String.concat "+" (List.sort String.compare interfaces) in let module XenAPI = Client.Client in let session_id = XenAPI.Session.login_with_password @@ -156,7 +156,7 @@ let rec monitor dbg () = let transform_taps devs = let newdevnames = Xapi_stdext_std.Listext.List.setify (List.map fst devs) in List.map (fun name -> - let devs' = List.filter (fun (n,x) -> n=name) devs in + let devs' = List.filter (fun (n,_) -> n=name) devs in let tot = List.fold_left (fun acc (_,b) -> {default_stats with rx_bytes = Int64.add acc.rx_bytes b.rx_bytes; @@ -175,7 +175,7 @@ let rec monitor dbg () = let open Network_server.Bridge in let bond_slaves = if List.mem_assoc dev bonds then - get_bond_link_info () dbg dev + get_bond_link_info () dbg ~name:dev else [] in @@ -261,8 +261,9 @@ let signal_networking_change () = let module XenAPI = Client.Client in let session = XenAPI.Session.slave_local_login_with_password ~rpc:xapi_rpc ~uname:"" ~pwd:"" in Pervasiveext.finally - (fun () -> XenAPI.Host.signal_networking_change xapi_rpc session) - (fun () -> XenAPI.Session.local_logout xapi_rpc session) + (fun () -> XenAPI.Host.signal_networking_change ~rpc:xapi_rpc + ~session_id:session) + (fun () -> XenAPI.Session.local_logout ~rpc:xapi_rpc ~session_id:session) (* Remove all outstanding reads on a file descriptor *) let clear_input fd = diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 08c4c159a..d3874a559 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -14,8 +14,6 @@ open Network_utils open Network_interface -open Xapi_stdext_std -open Xapi_stdext_unix open Xapi_stdext_monadic module S = Network_interface.Interface_API(Idl.Exn.GenServer ()) @@ -76,7 +74,7 @@ let clear_state () = let reset_state () = config := Network_config.read_management_conf () -let set_gateway_interface dbg name = +let set_gateway_interface _dbg name = (* Update dhclient conf for interface on changing default gateway. * If new default gateway is not same as gateway_interface from networkd.db then * we need to remove gateway information from gateway_interface *) @@ -93,7 +91,7 @@ let set_gateway_interface dbg name = debug "Setting gateway interface to %s" name; config := {!config with gateway_interface = Some name} -let set_dns_interface dbg name = +let set_dns_interface _dbg name = debug "Setting DNS interface to %s" name; config := {!config with dns_interface = Some name} @@ -127,12 +125,12 @@ module Sriov = struct let get_capabilities dev = let open Rresult.R.Infix in - let maxvfs_modprobe = + let maxvfs_modprobe = Sysfs.get_driver_name_err dev >>= fun driver -> Modprobe.get_config_from_comments driver |> Modprobe.get_maxvfs driver and maxvfs_sysfs = Sysfs.get_sriov_maxvfs dev in - let is_support = + let is_support = match maxvfs_modprobe, maxvfs_sysfs with | Ok v, _ -> v > 0 | Error _ , Ok v -> v > 0 @@ -209,7 +207,7 @@ module Sriov = struct debug "Config VF with pci address: %s" pcibuspath; match make_vf_conf_internal pcibuspath vf_info.mac vlan rate with | Result.Ok () -> (Ok:config_result) - | Result.Error (Fail_to_set_vf_rate, msg) -> + | Result.Error (Fail_to_set_vf_rate, msg) -> debug "%s" msg; Error Config_vf_rate_not_supported | Result.Error (_, msg) -> debug "%s" msg; Error (Unknown msg) @@ -364,7 +362,7 @@ module Interface = struct ignore (Dhclient.stop ~ipv6:true name); Sysctl.set_ipv6_autoconf name false; (* add the link_local and clean the old one only when needed *) - let cur_addrs = + let cur_addrs = let addrs = Ip.get_ipv6 name in let maybe_link_local = Ip.split_addr (Ip.get_ipv6_link_local_addr name) in match maybe_link_local with @@ -411,7 +409,7 @@ module Interface = struct List.iter (fun r -> Ip.set_route ~network:(r.subnet, r.netmask) name r.gateway) routes ) () - let get_dns dbg name = + let get_dns dbg _name = Debug.with_thread_associated dbg (fun () -> let nameservers, domains = Xapi_stdext_unix.Unixext.file_lines_fold (fun (nameservers, domains) line -> if Astring.String.is_prefix ~affix:"nameserver" line then @@ -464,7 +462,7 @@ module Interface = struct Debug.with_thread_associated dbg (fun () -> debug "Configuring ethtool settings for %s: %s" name (String.concat ", " (List.map (fun (k, v) -> k ^ "=" ^ v) params)); - let add_defaults = List.filter (fun (k, v) -> not (List.mem_assoc k params)) default_interface.ethtool_settings in + let add_defaults = List.filter (fun (k, _) -> not (List.mem_assoc k params)) default_interface.ethtool_settings in let params = params @ add_defaults in update_config name {(get_config name) with ethtool_settings = params}; Ethtool.set_options name params @@ -474,7 +472,7 @@ module Interface = struct Debug.with_thread_associated dbg (fun () -> debug "Configuring ethtool offload settings for %s: %s" name (String.concat ", " (List.map (fun (k, v) -> k ^ "=" ^ v) params)); - let add_defaults = List.filter (fun (k, v) -> not (List.mem_assoc k params)) default_interface.ethtool_offload in + let add_defaults = List.filter (fun (k, _) -> not (List.mem_assoc k params)) default_interface.ethtool_offload in let params = params @ add_defaults in update_config name {(get_config name) with ethtool_offload = params}; Ethtool.set_offload name params @@ -534,7 +532,7 @@ module Interface = struct if conservative then begin (* Do not touch non-persistent interfaces *) debug "Only configuring persistent interfaces"; - List.filter (fun (name, interface) -> interface.persistent_i) config + List.filter (fun (_name, interface) -> interface.persistent_i) config end else config in @@ -709,11 +707,11 @@ module Bridge = struct (debug "%s isn't a valid setting for other_config:vswitch-disable-in-band" dib; None) in - let old_igmp_snooping = Ovs.get_mcast_snooping_enable name in + let old_igmp_snooping = Ovs.get_mcast_snooping_enable ~name in ignore (Ovs.create_bridge ?mac ~fail_mode ?external_id ?disable_in_band ?igmp_snooping vlan vlan_bug_workaround name); if igmp_snooping = Some true && not old_igmp_snooping then - Ovs.inject_igmp_query name + Ovs.inject_igmp_query ~name | Bridge -> ignore (Brctl.create_bridge name); @@ -832,8 +830,8 @@ module Bridge = struct let get_all_ports dbg from_cache = Debug.with_thread_associated dbg (fun () -> if from_cache then - let ports = List.concat (List.map (fun (_, {ports}) -> ports) !config.bridge_config) in - List.map (fun (port, {interfaces}) -> port, interfaces) ports + let ports = List.concat (List.map (fun (_, {ports;_}) -> ports) !config.bridge_config) in + List.map (fun (port, {interfaces;_}) -> port, interfaces) ports else match !backend_kind with | Openvswitch -> List.concat (List.map Ovs.bridge_to_ports (Ovs.list_bridges ())) @@ -850,8 +848,8 @@ module Bridge = struct let get_all_bonds dbg from_cache = Debug.with_thread_associated dbg (fun () -> if from_cache then - let ports = List.concat (List.map (fun (_, {ports}) -> ports) !config.bridge_config) in - let names = List.map (fun (port, {interfaces}) -> port, interfaces) ports in + let ports = List.concat (List.map (fun (_, {ports;_}) -> ports) !config.bridge_config) in + let names = List.map (fun (port, {interfaces;_}) -> port, interfaces) ports in List.filter (fun (_, ifs) -> List.length ifs > 1) names else match !backend_kind with @@ -911,7 +909,8 @@ module Bridge = struct | Bridge -> () ) () - let add_basic_port dbg bridge name {interfaces; bond_mac; bond_properties} = + let add_basic_port dbg bridge name + {interfaces; bond_mac; bond_properties;_} = match !backend_kind with | Openvswitch -> if List.length interfaces = 1 then begin @@ -963,7 +962,7 @@ module Bridge = struct end else ignore (Brctl.create_port bridge name) - let add_pvs_proxy_port dbg bridge name port = + let add_pvs_proxy_port dbg bridge name _port = match !backend_kind with | Openvswitch -> ignore (Ovs.create_port ~internal:true name bridge); @@ -1077,7 +1076,7 @@ module Bridge = struct let make_config dbg conservative config = Debug.with_thread_associated dbg (fun () -> - let vlans_go_last (_, {vlan=vlan_of_a}) (_, {vlan=vlan_of_b}) = + let vlans_go_last (_, {vlan=vlan_of_a;_}) (_, {vlan=vlan_of_b;_}) = if vlan_of_a = None && vlan_of_b = None then 0 else if vlan_of_a <> None && vlan_of_b = None then 1 else if vlan_of_a = None && vlan_of_b <> None then -1 @@ -1085,11 +1084,11 @@ module Bridge = struct in let config = if conservative then begin - let persistent_config = List.filter (fun (name, bridge) -> bridge.persistent_b) config in + let persistent_config = List.filter (fun (_name, bridge) -> bridge.persistent_b) config in debug "Ensuring the following persistent bridges are up: %s" (String.concat ", " (List.map (fun (name, _) -> name) persistent_config)); let vlan_parents = Xapi_stdext_std.Listext.List.filter_map (function - | (_, {vlan=Some (parent, _)}) -> + | (_, {vlan=Some (parent, _);_}) -> if not (List.mem_assoc parent persistent_config) then Some (parent, List.assoc parent config) else @@ -1132,13 +1131,13 @@ module PVS_proxy = struct error "Error when calling PVS proxy: %s" (Printexc.to_string e); raise (Network_error PVS_proxy_connection_error) - let configure_site dbg config = + let configure_site _dbg config = debug "Configuring PVS proxy for site %s" config.site_uuid; let call = {Rpc.name = "configure_site"; params = [Rpcmarshal.marshal t.ty config]} in let _ = do_call call in () - let remove_site dbg uuid = + let remove_site _dbg uuid = debug "Removing PVS proxy for site %s" uuid; let call = Rpc.{name = "remove_site"; params = [Dict ["site_uuid", Rpcmarshal.marshal Rpc.Types.string.ty uuid]]} in let _ = do_call call in @@ -1156,7 +1155,7 @@ let on_startup () = let file = String.trim (Xapi_stdext_unix.Unixext.string_of_file "/etc/sysconfig/network") in let args = Astring.String.cuts ~empty:false ~sep:"\n" file in let args = List.map (fun s -> match (Astring.String.cuts ~sep:"=" s) with k :: [v] -> k, v | _ -> "", "") args in - let args = List.filter (fun (k, v) -> k <> "DNSDEV" && k <> "GATEWAYDEV") args in + let args = List.filter (fun (k, _) -> k <> "DNSDEV" && k <> "GATEWAYDEV") args in let s = String.concat "\n" (List.map (fun (k, v) -> k ^ "=" ^ v) args) ^ "\n" in Xapi_stdext_unix.Unixext.write_string_to_file "/etc/sysconfig/network" s with _ -> () diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 6393d850f..08f6b26ae 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -12,12 +12,7 @@ * GNU Lesser General Public License for more details. *) -open Xapi_stdext_pervasives.Pervasiveext -open Network_utils - module D = Debug.Make(struct let name = "networkd" end) -open D - let resources = [ { Xcp_service.name = "network-conf"; diff --git a/networkd_db/networkd_db.ml b/networkd_db/networkd_db.ml index 08d86b3e3..10d8df0d1 100644 --- a/networkd_db/networkd_db.ml +++ b/networkd_db/networkd_db.ml @@ -17,7 +17,7 @@ open Network_interface let name = "networkd_db" (* catch signals for clean shutdown *) -let stop signal = +let stop _signal = exit 0 let handle_shutdown () = From 142a4e99b20ebb6be9ef4114388e5112b0061d5b Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Tue, 4 Dec 2018 16:18:16 +0000 Subject: [PATCH 208/260] CP-27898 update Travis configuration Signed-off-by: Christian Lindig --- .travis.yml | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/.travis.yml b/.travis.yml index 7d852f87a..300fad7f3 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,12 +1,12 @@ language: c -services: docker -install: - - wget https://raw.githubusercontent.com/xenserver/xenserver-build-env/master/utils/travis-build-repo.sh -script: bash travis-build-repo.sh -sudo: true +sudo: required +service: docker +install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh +script: bash -ex .travis-docker.sh env: - global: - - REPO_PACKAGE_NAME=xcp-networkd - - REPO_CONFIGURE_CMD=true - - REPO_BUILD_CMD=make - - REPO_TEST_CMD='make test' + global: + - PACKAGE="xcp-networkd" + - PINS="xcp-networkd:." + - BASE_REMOTE="https://github.com/xcp-networkd-project/xs-opam.git" + matrix: + - DISTRO="debian-9-ocaml-4.06" From dae80ec8aa05d2d00546219fe6f9739e10fa16b6 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Tue, 4 Dec 2018 16:20:35 +0000 Subject: [PATCH 209/260] CP-27898 Remove outdated COVERAGE.md Coverage needs to be handled in dune files and currently is not. Signed-off-by: Christian Lindig --- COVERAGE.md | 45 --------------------------------------------- 1 file changed, 45 deletions(-) delete mode 100644 COVERAGE.md diff --git a/COVERAGE.md b/COVERAGE.md deleted file mode 100644 index d8ea101f1..000000000 --- a/COVERAGE.md +++ /dev/null @@ -1,45 +0,0 @@ - -# Coverage Analysis - -This project can be compiled for coverage analysis using [bisect_ppx]. By -default, this is not done. To compile for coverage analysis, do: - - make coverage - make - -The `coverage` target adds the rules in `_tags.coverage` to the `_tags` -file, which in turn causes all code to be compiled for coverage -analysis. The `_tags.coverage` file could be tweaked to control which -files get instrumented. - -## Support Files - -See [profiling/coverage.ml](./profiling/coverage.ml) for the run-time -setup of coverage profiling. This code has no effect when not profiling -during execution. Once [bixect_ppx] has better defaults we could get rid -of it. - -## Execution and Logging - -During program execution, a binary writes coverage data to - - /tmp/bisect--*.out - -This can be overridden by setting the `BISECT_FILE` environment -variable, which is otherwise set at startup using the code in -`profiling/coverage.ml`; - -## Analysis - -See the [bisect_ppx] documentation for details but try from the -top-level directory: - - bisect-ppx-report -I _build -html coverage /tmp/bisect-*.out - -This creates an HTML document in [coverage/](./coverage]. - -[bisect_ppx]: https://github.com/aantron/bisect_ppx - - - - From 18f383fbd786126bf723f13d3f4814c955cd1178 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Tue, 4 Dec 2018 16:34:00 +0000 Subject: [PATCH 210/260] CP-27898 add profiling with gprof to Makefile Signed-off-by: Christian Lindig --- Makefile | 7 ++++++- dune | 14 ++++++++++++++ 2 files changed, 20 insertions(+), 1 deletion(-) create mode 100644 dune diff --git a/Makefile b/Makefile index c0b821066..b5630cda4 100644 --- a/Makefile +++ b/Makefile @@ -30,7 +30,12 @@ clean: dune clean test: - dune runtest --profile=$(PROFIE) + dune runtest --profile=$(PROFILE) + +gprof: + dune runtest --profile=gprof + @echo "To view results, run:" + @echo "gprof _build/default/test/network_test.exe _build/default/gmon.out" # requires odoc doc: diff --git a/dune b/dune new file mode 100644 index 000000000..16ae5de74 --- /dev/null +++ b/dune @@ -0,0 +1,14 @@ +(env + (gprof + (ocamlopt_flags + (:standard -g -p) + ) + (flags (:standard)) + ) + (dev + (flags (:standard)) + ) + (release + (flags (:standard)) + ) +) From c8b072d218024be7c9a1d6bd16a8e7b98b4e5395 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Tue, 4 Dec 2018 16:38:38 +0000 Subject: [PATCH 211/260] CP-27898 update INSTALL Signed-off-by: Christian Lindig --- INSTALL | 16 +--------------- 1 file changed, 1 insertion(+), 15 deletions(-) diff --git a/INSTALL b/INSTALL index f7f3645cd..2f0594336 100644 --- a/INSTALL +++ b/INSTALL @@ -3,18 +3,4 @@ The easiest way to install is via opam: - opam init - opam remote add xen-org git://github.com/xen-org/opam-repo-dev - opam install xcp-networkd - -# Coverage Profiling - -This code can be instrumented for coverage profiling: - - make coverage - make - -See [COVERAGE.md](./COVERAGE.md) for details and -[profiling/](./profiling/) for supporting code. - - + opam pin add . From 84f446ca661fbec65bbfc545f5ab72b1ffda5245 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Tue, 4 Dec 2018 16:41:03 +0000 Subject: [PATCH 212/260] CP-27898 update ChangeLog Signed-off-by: Christian Lindig --- ChangeLog | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index ad0084a53..e417faf59 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,6 @@ +0.39.0 (04-Dec-2018) +* This file in no longer maintained. See the Git history' + 0.10.0 (14-Aug-2015): * Preliminary support for FCoE * Support xapi `originator` @@ -15,7 +18,7 @@ 0.9.4 (3-Jun-2014): * Use oasis for building * Update to new stdext interface -* Fix CA-118425/SCTX-1559: An earlier error could cause problems with VLANs +* Fix CA-118425/SCTX-1559: An earlier error could cause problems with VLANs * Enable LACP bonding on linux bridge * Fix CA-116420: Bonds were getting incorrect MAC addresses on 3.x kernels * Fix CA-120846: Finding MAC addresses for bonds From 5d3163bbfb9ff9d22289c0982eb4e963a403bc3a Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Tue, 4 Dec 2018 16:55:32 +0000 Subject: [PATCH 213/260] CP-27898 update opam file, Travis Signed-off-by: Christian Lindig --- .travis.yml | 6 +++--- xapi-networkd.opam | 22 ++++++++++++++-------- 2 files changed, 17 insertions(+), 11 deletions(-) diff --git a/.travis.yml b/.travis.yml index 300fad7f3..3b593cfd4 100644 --- a/.travis.yml +++ b/.travis.yml @@ -5,8 +5,8 @@ install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.t script: bash -ex .travis-docker.sh env: global: - - PACKAGE="xcp-networkd" - - PINS="xcp-networkd:." - - BASE_REMOTE="https://github.com/xcp-networkd-project/xs-opam.git" + - PACKAGE="xapi-networkd" + - PINS="xapi-networkd:." + - BASE_REMOTE="https://github.com/xapi-project/xs-opam.git" matrix: - DISTRO="debian-9-ocaml-4.06" diff --git a/xapi-networkd.opam b/xapi-networkd.opam index 82590549b..9d44ba4ee 100644 --- a/xapi-networkd.opam +++ b/xapi-networkd.opam @@ -1,5 +1,5 @@ opam-version: "2.0" -maintainer: "jonathan.ludlam@eu.citrix.com" +maintainer: "xen-api@lists.xen.org" authors: "jonathan.ludlam@eu.citrix.com" homepage: "https://github.com/xapi-project/xcp-networkd" dev-repo: "git+https://github.com/xapi-project/xcp-networkd.git" @@ -9,20 +9,26 @@ build: [ ["dune" "runtest" "-p" name] {with-test} ] depends: [ - "ocaml" - "dune" {build} + "astring" + "base-threads" + "forkexec" + "mtime" "netlink" - "rpc" + "ounit" + "re" + "rpclib" "systemd" - "xapi-forkexecd" "xapi-idl" "xapi-inventory" - "xapi-libs-transitional" - "xapi-stdext" {>= "3.0.0"} + "xapi-stdext-monadic" + "xapi-stdext-pervasives" + "xapi-stdext-threads" + "xapi-stdext-unix" + "xapi-test-utils" "xen-api-client" ] synopsis: "The XCP networking daemon" url { src: "https://github.com/xapi-project/xcp-networkd/archive/master/master.tar.gz" -} \ No newline at end of file +} From 07fe597f3daec91314606a3fc2c6028e16a2aa6d Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Wed, 5 Dec 2018 14:13:38 +0000 Subject: [PATCH 214/260] CP-27898 reformat dune files Signed-off-by: Christian Lindig --- lib/dune | 13 ++++++++++++- networkd/dune | 18 ++++++++++++++++-- networkd_db/dune | 6 +++++- test/dune | 11 +++++++---- 4 files changed, 40 insertions(+), 8 deletions(-) diff --git a/lib/dune b/lib/dune index 341cb6245..1d1fa10e3 100644 --- a/lib/dune +++ b/lib/dune @@ -1,5 +1,16 @@ (library (name networklibs) - (libraries astring forkexec mtime mtime.clock.os rpclib systemd threads re.perl xapi-stdext-unix xapi-inventory xapi-idl.network) + (libraries + astring + forkexec + mtime + mtime.clock.os + rpclib + systemd + threads + re.perl + xapi-stdext-unix + xapi-inventory + xapi-idl.network) (wrapped false) ) diff --git a/networkd/dune b/networkd/dune index 67526d132..1d8e733df 100644 --- a/networkd/dune +++ b/networkd/dune @@ -24,8 +24,22 @@ (name networkd) (public_name xapi-networkd) (package xapi-networkd) - (libraries forkexec netlink networklibs profiling rpclib systemd threads xapi-stdext-monadic xapi-stdext-pervasives xapi-stdext-threads xapi-stdext-unix xapi-inventory xapi-idl xapi-idl.network xen-api-client) -) + (libraries + forkexec + netlink + networklibs + profiling + rpclib + systemd + threads + xapi-stdext-monadic + xapi-stdext-pervasives + xapi-stdext-threads + xapi-stdext-unix + xapi-inventory + xapi-idl + xapi-idl.network + xen-api-client)) (alias (name man) diff --git a/networkd_db/dune b/networkd_db/dune index 9b3c4a2e1..fd93a9b97 100644 --- a/networkd_db/dune +++ b/networkd_db/dune @@ -2,5 +2,9 @@ (name networkd_db) (public_name networkd_db) (package xapi-networkd) - (libraries networklibs profiling threads xapi-idl.network) + (libraries + networklibs + profiling + threads + xapi-idl.network) ) diff --git a/test/dune b/test/dune index 9c06421cc..ba5a912b8 100644 --- a/test/dune +++ b/test/dune @@ -1,6 +1,11 @@ (executable (name network_test) - (libraries astring networklibs oUnit profiling xapi-test-utils) + (libraries + astring + networklibs + oUnit + profiling + xapi-test-utils) ) (alias @@ -10,9 +15,7 @@ (source_tree jsonrpc_files) ) (action - (chdir - ../ - (run %{x}) + (chdir ../ (run %{x}) ) ) ) From b404061b102e3a29a5a0e35299b2b9cb7f745386 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Wed, 5 Dec 2018 14:58:06 +0000 Subject: [PATCH 215/260] CP-27898 remove -j $(JOBS) in Makefile Signed-off-by: Christian Lindig --- INSTALL | 2 ++ Makefile | 5 ++--- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/INSTALL b/INSTALL index 2f0594336..8146b5d85 100644 --- a/INSTALL +++ b/INSTALL @@ -3,4 +3,6 @@ The easiest way to install is via opam: + opam repo add xs-opam https://github.com/xapi-project/xs-opam.git opam pin add . + diff --git a/Makefile b/Makefile index b5630cda4..20e6f711f 100644 --- a/Makefile +++ b/Makefile @@ -1,17 +1,16 @@ BINDIR ?= /usr/bin SBINDIR ?= /usr/sbin MANDIR ?= /usr/share/man/man1 -JOBS = $(shell getconf _NPROCESSORS_ONLN) PROFILE=release .PHONY: release build install uninstall clean test doc reindent release: - dune build @install @networkd/man --profile=$(PROFILE) -j $(JOBS) + dune build @install @networkd/man --profile=$(PROFILE) build: - dune build @install @networkd/man -j $(JOBS) + dune build @install @networkd/man install: mkdir -p $(DESTDIR)$(SBINDIR) From 2b5a0298553f00551af4c3bad220d5a96f6b480b Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Wed, 5 Dec 2018 15:11:12 +0000 Subject: [PATCH 216/260] CP-27898 remove dead code Signed-off-by: Christian Lindig --- lib/network_utils.ml | 17 ----------- networkd/network_server.ml | 60 -------------------------------------- networkd_db/networkd_db.ml | 9 ------ 3 files changed, 86 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 6a1381469..f60ffe804 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -416,11 +416,6 @@ module Ip = struct let get_mtu dev = int_of_string (List.hd (link dev "mtu")) - let get_state dev = - match addr dev "state" with - | "UP" :: _ -> true - | _ -> false - let get_mac dev = List.hd (link dev "link/ether") @@ -897,10 +892,6 @@ module Proc = struct error "Error: could not read /proc/net/vlan/config"; [] - let get_bond_links_up name = - let statusses = get_bond_slave_info name "MII Status" in - List.fold_left (fun x (_, y) -> x + (if y = "up" then 1 else 0)) 0 statusses - let get_ipv6_disabled () = try Unixext.string_of_file "/proc/sys/net/ipv6/conf/all/disable_ipv6" @@ -1025,11 +1016,6 @@ module Ovs = struct ) ([], None) lines with _ -> [], None - let get_bond_links_up name = - let slaves, _ = get_bond_link_status name in - let links_up = List.filter snd slaves in - List.length (links_up) - let get_bond_mode name = try let output = String.trim (vsctl ~log:false ["get"; "port"; name; "bond_mode"]) in @@ -1209,9 +1195,6 @@ module Ovs = struct let destroy_port name = vsctl ["--"; "--with-iface"; "--if-exists"; "del-port"; name] - let port_to_bridge name = - vsctl ~log:false ["port-to-br"; name] - let make_bond_properties name properties = let known_props = ["mode"; "hashing-algorithm"; "updelay"; "downdelay"; "miimon"; "use_carrier"; "rebalance-interval"; diff --git a/networkd/network_server.ml b/networkd/network_server.ml index d3874a559..eb645f746 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -376,16 +376,6 @@ module Interface = struct end ) () - let get_ipv6_gateway _ dbg ~name = - Debug.with_thread_associated dbg (fun () -> - let output = Ip.route_show ~version:Ip.V6 name in - try - let line = List.find (fun s -> Astring.String.is_prefix ~affix:"default via" s) (Astring.String.cuts ~empty:false ~sep:"\n" output) in - let addr = List.nth (Astring.String.cuts ~empty:false ~sep:" " line) 2 in - Some (Unix.inet_addr_of_string addr) - with Not_found -> None - ) () - let set_ipv6_gateway _ dbg ~name ~address = Debug.with_thread_associated dbg (fun () -> if Proc.get_ipv6_disabled () then @@ -511,11 +501,6 @@ module Interface = struct Ip.link_set_down name ) () - let is_persistent _ dbg ~name = - Debug.with_thread_associated dbg (fun () -> - (get_config name).persistent_i - ) () - let set_persistent dbg name value = Debug.with_thread_associated dbg (fun () -> debug "Making interface %s %spersistent" name (if value then "" else "non-"); @@ -598,13 +583,6 @@ module Bridge = struct warn "Network-conf file not found. Falling back to Open vSwitch."; backend_kind := Openvswitch - let get_bond_links_up _ dbg ~name = - Debug.with_thread_associated dbg (fun () -> - match !backend_kind with - | Openvswitch -> Ovs.get_bond_links_up name - | Bridge -> Proc.get_bond_links_up name - ) () - let get_all dbg () = Debug.with_thread_associated dbg (fun () -> match !backend_kind with @@ -820,13 +798,6 @@ module Bridge = struct !backend_kind ) () - let get_ports _ dbg ~name = - Debug.with_thread_associated dbg (fun () -> - match !backend_kind with - | Openvswitch -> Ovs.bridge_to_ports name - | Bridge -> raise (Network_error Not_implemented) - ) () - let get_all_ports dbg from_cache = Debug.with_thread_associated dbg (fun () -> if from_cache then @@ -838,13 +809,6 @@ module Bridge = struct | Bridge -> raise (Network_error Not_implemented) ) () - let get_bonds _ dbg ~name = - Debug.with_thread_associated dbg (fun () -> - match !backend_kind with - | Openvswitch -> Ovs.bridge_to_ports name - | Bridge -> raise (Network_error Not_implemented) - ) () - let get_all_bonds dbg from_cache = Debug.with_thread_associated dbg (fun () -> if from_cache then @@ -895,13 +859,6 @@ module Bridge = struct ) slaves ) () - let get_vlan _ dbg ~name = - Debug.with_thread_associated dbg (fun () -> - match !backend_kind with - | Openvswitch -> Ovs.bridge_to_vlan name - | Bridge -> raise (Network_error Not_implemented) - ) () - let add_default_flows _ dbg bridge mac interfaces = Debug.with_thread_associated dbg (fun () -> match !backend_kind with @@ -1051,23 +1008,6 @@ module Bridge = struct physical_ifaces ) () - let get_fail_mode _ dbg ~name = - Debug.with_thread_associated dbg (fun () -> - match !backend_kind with - | Openvswitch -> - begin match Ovs.get_fail_mode name with - | "standalone" -> Some Standalone - | "secure" -> Some Secure - | _ -> None - end - | Bridge -> raise (Network_error Not_implemented) - ) () - - let is_persistent _ dbg ~name = - Debug.with_thread_associated dbg (fun () -> - (get_config name).persistent_b - ) () - let set_persistent dbg name value = Debug.with_thread_associated dbg (fun () -> debug "Making bridge %s %spersistent" name (if value then "" else "non-"); diff --git a/networkd_db/networkd_db.ml b/networkd_db/networkd_db.ml index 10d8df0d1..408efd2d1 100644 --- a/networkd_db/networkd_db.ml +++ b/networkd_db/networkd_db.ml @@ -16,15 +16,6 @@ open Network_interface let name = "networkd_db" -(* catch signals for clean shutdown *) -let stop _signal = - exit 0 - -let handle_shutdown () = - Sys.set_signal Sys.sigterm (Sys.Signal_handle stop); - Sys.set_signal Sys.sigint (Sys.Signal_handle stop); - Sys.set_signal Sys.sigpipe Sys.Signal_ignore - let _ = let bridge = ref "" in let iface = ref "" in From 629ba03d42da368fced7d525aaa70bc7d0717aca Mon Sep 17 00:00:00 2001 From: Igor Druzhinin Date: Wed, 19 Dec 2018 17:10:11 +0000 Subject: [PATCH 217/260] CA-305355: Bumping dracut timeout default up to 3min for 4.19 kernel SR-IOV tests are currently failing due to initrd building being a bit slower sometimes for Linux 4.19 (~5s more then the current default). Signed-off-by: Igor Druzhinin --- lib/network_utils.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index f60ffe804..a86716125 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -51,7 +51,7 @@ let bonding_dir = "/proc/net/bonding/" let uname = ref "/usr/bin/uname" let dracut = ref "/sbin/dracut" let modinfo = ref "/sbin/modinfo" -let dracut_timeout = ref 120.0 +let dracut_timeout = ref 180.0 let fcoedriver = ref "/opt/xensource/libexec/fcoe_driver" let inject_igmp_query_script = ref "/usr/libexec/xenopsd/igmp_query_injector.py" let mac_table_size = ref 10000 From 9b81db6bd77b8d442191e143562489af8128bcca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 2 Jan 2019 13:01:41 +0000 Subject: [PATCH 218/260] Use OCaml 4.07 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 3b593cfd4..a6b10e8aa 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,4 +9,4 @@ env: - PINS="xapi-networkd:." - BASE_REMOTE="https://github.com/xapi-project/xs-opam.git" matrix: - - DISTRO="debian-9-ocaml-4.06" + - DISTRO="debian-9-ocaml-4.07" From 133f490166ba7fc41883ccc71ac8f6d153a79d8e Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 12 Feb 2019 10:30:41 +0000 Subject: [PATCH 219/260] CA-310516: Detect 'xentemp' vlans as managed On first boot networkd may create a vlan named xentemp and the firstboot script call xapi to create that same vlan to get recognized by xapi. networkd need to recognise this case, otherwise an error occurs and the setup fails. Signed-off-by: Pau Ruiz Safont --- networkd/network_server.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index eb645f746..1e6871254 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -486,7 +486,8 @@ module Interface = struct let has_vlan dbg name vlan = (* Identify the vlan is used by kernel which is unknown to XAPI *) Debug.with_thread_associated dbg (fun () -> - List.exists (fun (_, v, p) -> v = vlan && p = name) (Proc.get_vlans ()) + let temp_interfaces = Sysfs.bridge_to_interfaces "xentemp" in + List.exists (fun (d, v, p) -> v = vlan && p = name && not (List.mem d temp_interfaces)) (Proc.get_vlans ()) ) () let bring_up _ dbg ~name = From 4c1e2af8c16ef3e522179454d4b42bb66de41c1e Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 12 Feb 2019 10:36:11 +0000 Subject: [PATCH 220/260] maintenance: whitespace Signed-off-by: Pau Ruiz Safont --- lib/network_utils.ml | 72 +++++++++++++++++++------------------- networkd/network_server.ml | 4 +-- 2 files changed, 38 insertions(+), 38 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index a86716125..682a63ff6 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -249,7 +249,7 @@ module Sysfs = struct |> (fun p -> try read_one_line p |> duplex_of_string with _ -> Duplex_unknown) in (speed, duplex) - let get_dev_nums_with_same_driver driver = + let get_dev_nums_with_same_driver driver = try Sys.readdir ("/sys/bus/pci/drivers/" ^ driver) |> Array.to_list @@ -264,7 +264,7 @@ module Sysfs = struct Result.Ok devices.(0) with _ -> Result.Error (Parent_device_of_vf_not_found, "Can not get parent device for " ^ pcibuspath) - let get_child_vfs_sysfs_paths dev = + let get_child_vfs_sysfs_paths dev = try let device_path = getpath dev "device" in Result. Ok ( @@ -279,7 +279,7 @@ module Sysfs = struct try let open Rresult.R.Infix in get_child_vfs_sysfs_paths parent_dev >>= fun paths -> - let group = + let group = List.find (fun x -> Astring.String.is_infix ~affix:pcibuspath (Unix.readlink x)) paths |> Re.exec_opt (Re.Perl.compile_pat "virtfn(\\d+)") in @@ -291,25 +291,25 @@ module Sysfs = struct let unbind_child_vfs dev = let open Rresult.R.Infix in let unbind vf_path = - let driver_name = + let driver_name = try Unix.readlink (Filename.concat vf_path "driver") |> Filename.basename - with _ -> "" + with _ -> "" and vf_pcibuspath = Unix.readlink vf_path |> Filename.basename in if driver_name = "" then Result.Ok () (* not bind to any driver, Ok *) else begin - debug "unbinding %s from driver %s at %s" vf_path driver_name vf_pcibuspath; + debug "unbinding %s from driver %s at %s" vf_path driver_name vf_pcibuspath; let unbind_interface = Filename.concat vf_path "driver/unbind" and remove_slot_interface = Filename.concat vf_path "driver/remove_slot" in begin try write_one_line remove_slot_interface vf_pcibuspath with _ -> () end; - try + try write_one_line unbind_interface vf_pcibuspath; Result.Ok () with _ -> Result.Error (Fail_to_unbind_from_driver, Printf.sprintf "%s: VF Fail to be unbound from driver %s" vf_path driver_name) end @@ -320,7 +320,7 @@ module Sysfs = struct let get_sriov_numvfs dev = try getpath dev "device/sriov_numvfs" - |> read_one_line + |> read_one_line |> String.trim |> int_of_string with _ -> 0 @@ -328,7 +328,7 @@ module Sysfs = struct let get_sriov_maxvfs dev = try Ok (getpath dev "device/sriov_totalvfs" - |> read_one_line + |> read_one_line |> String.trim |> int_of_string) with _ -> Error (Fail_to_get_maxvfs, "Failed to get maxvfs from sysfs interface for device: " ^ dev) @@ -501,7 +501,7 @@ module Ip = struct ignore (call [mode; "addr"; "flush"; "dev"; dev]) with _ -> () - let del_ip_addr dev (ip, prefixlen) = + let del_ip_addr dev (ip, prefixlen) = let addr = Printf.sprintf "%s/%d" (Unix.string_of_inet_addr ip) prefixlen in try Sysfs.assert_exists dev; @@ -745,8 +745,8 @@ module Dhclient = struct let[@warning "-27"] generate_conf ?(ipv6=false) interface options = let minimal = ["subnet-mask"; "broadcast-address"; "time-offset"; "host-name"; "nis-domain"; "nis-servers"; "ntp-servers"; "interface-mtu"] in - let set_gateway = - if List.mem (`gateway interface) options + let set_gateway = + if List.mem (`gateway interface) options then (debug "%s is the default gateway interface" interface; ["routers"]) else (debug "%s is NOT the default gateway interface" interface; []) in @@ -769,9 +769,9 @@ module Dhclient = struct (* but some buggy DHCP servers ignore this *) (* See CA-137892 *) let gw_opt = List.fold_left - (fun l x -> - match x with - | `gateway y -> ["-e"; "GATEWAYDEV="^y] + (fun l x -> + match x with + | `gateway y -> ["-e"; "GATEWAYDEV="^y] | _ -> l) [] options in write_conf_file ~ipv6 interface options; let ipv6' = if ipv6 then ["-6"] else [] in @@ -1090,9 +1090,9 @@ module Ovs = struct let get_bridge_vlan_vifs ~name = try let vlan_fake_bridges = get_vlans name in - List.fold_left(fun vifs br -> + List.fold_left(fun vifs br -> let vifs' = bridge_to_interfaces br in - vifs' @ vifs) [] vlan_fake_bridges + vifs' @ vifs) [] vlan_fake_bridges with _ -> [] let get_mcast_snooping_enable ~name = @@ -1387,20 +1387,20 @@ module Modprobe = struct Result.Ok () with _ -> Result.Error (Fail_to_write_modprobe_cfg, "Failed to write modprobe configuration file for: " ^ driver) - (* - For a igb driver, the module config file will be at path `/etc/modprobe.d/igb.conf` - The module config file is like: - # VFs-param: max_vfs - # VFs-maxvfs-by-default: 7 - # VFs-maxvfs-by-user: - options igb max_vfs=7,7 - - Example of calls: - "igb" -> "VFs-param" -> Some "max_vfs" - "igb" -> "VFs-maxvfs-by-default" -> Some "7" - "igb" -> "VFs-maxvfs-by-user" -> None - "igb" -> "Not existed comments" -> None - *) + (* + For a igb driver, the module config file will be at path `/etc/modprobe.d/igb.conf` + The module config file is like: + # VFs-param: max_vfs + # VFs-maxvfs-by-default: 7 + # VFs-maxvfs-by-user: + options igb max_vfs=7,7 + + Example of calls: + "igb" -> "VFs-param" -> Some "max_vfs" + "igb" -> "VFs-maxvfs-by-default" -> Some "7" + "igb" -> "VFs-maxvfs-by-user" -> None + "igb" -> "Not existed comments" -> None + *) let get_config_from_comments driver = try let open Xapi_stdext_std.Listext in @@ -1428,12 +1428,12 @@ module Modprobe = struct with _ -> None let get_maxvfs driver config = - let get_default_maxvfs config = + let get_default_maxvfs config = try Some (List.assoc "VFs-maxvfs-by-default" config |> int_of_string) with _ -> None in - let get_user_defined_maxvfs config = + let get_user_defined_maxvfs config = try Some (List.assoc "VFs-maxvfs-by-user" config |> int_of_string) with _ -> None @@ -1461,8 +1461,8 @@ module Modprobe = struct end >>= fun option -> let need_rebuild_initrd = ref false in let has_probe_conf = ref false in - let parse_single_line s = - let parse_driver_options s = + let parse_single_line s = + let parse_driver_options s = match Astring.String.cut ~sep:"=" s with (* has SR-IOV configuration but the max_vfs is exactly what we want to set, so no changes and return s *) | Some (k, v) when k = vf_param && v = option -> has_probe_conf := true; s @@ -1489,7 +1489,7 @@ module Modprobe = struct | true, true -> write_conf_file driver new_conf >>= fun () -> Dracut.rebuild_initrd () - | false, false -> + | false, false -> let new_option_line = Printf.sprintf "options %s %s=%s" driver vf_param option in write_conf_file driver (new_conf @ [new_option_line]) >>= fun () -> Dracut.rebuild_initrd () diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 1e6871254..0d16758b7 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -174,7 +174,7 @@ module Sriov = struct ) () let disable dbg name = - Debug.with_thread_associated dbg (fun () -> + Debug.with_thread_associated dbg (fun () -> debug "Disable network SR-IOV by name: %s" name; match config_sriov ~enable:false name with | Ok _ -> (Ok:disable_result) @@ -200,7 +200,7 @@ module Sriov = struct (fun () -> Ip.set_vf_rate dev index 0) rate let make_vf_config dbg pci_address (vf_info : sriov_pci_t) = - Debug.with_thread_associated dbg (fun () -> + Debug.with_thread_associated dbg (fun () -> let vlan = Opt.map Int64.to_int vf_info.vlan and rate = Opt.map Int64.to_int vf_info.rate and pcibuspath = Xcp_pci.string_of_address pci_address in From 5d46ad92bfce7d87a196886d3d905f46b3fe3938 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 12 Feb 2019 10:50:22 +0000 Subject: [PATCH 221/260] CA-310516: Define name of temporary vlan only once Signed-off-by: Pau Ruiz Safont --- lib/network_config.ml | 4 +++- networkd/network_server.ml | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/lib/network_config.ml b/lib/network_config.ml index ececc3973..1f9c4ba43 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -23,6 +23,8 @@ exception Write_error let empty_config = default_config let config_file_path = "/var/lib/xcp/networkd.db" +let temp_vlan = "xentemp" + let bridge_naming_convention (device: string) = if Astring.String.is_prefix ~affix:"eth" device @@ -56,7 +58,7 @@ let read_management_conf () = (* At this point, we don't know what the VLAN bridge name will be, * so use a temporary name. Xapi will replace the bridge once the name * has been decided on. *) - "xentemp" + temp_vlan in debug "No management bridge in inventory file... using %s" bridge; bridge diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 0d16758b7..5ff149b1d 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -486,7 +486,7 @@ module Interface = struct let has_vlan dbg name vlan = (* Identify the vlan is used by kernel which is unknown to XAPI *) Debug.with_thread_associated dbg (fun () -> - let temp_interfaces = Sysfs.bridge_to_interfaces "xentemp" in + let temp_interfaces = Sysfs.bridge_to_interfaces Network_config.temp_vlan in List.exists (fun (d, v, p) -> v = vlan && p = name && not (List.mem d temp_interfaces)) (Proc.get_vlans ()) ) () From cd5df52b2188f0b339bf69c6a06d6d0198935cd2 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Wed, 13 Feb 2019 16:47:32 +0000 Subject: [PATCH 222/260] CA-310413: Unconditionally apply enic workaround (again) This reverts 9d5309e8018664ed2766e52aeeb1f39d26c5a88d. The reason is that the workaround is once again needed on the current version of the enic driver. Signed-off-by: Rob Hoes --- lib/network_utils.ml | 7 ------- networkd/network_server.ml | 21 +-------------------- networkd/networkd.ml | 1 - 3 files changed, 1 insertion(+), 28 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 682a63ff6..26204b4fa 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -123,13 +123,6 @@ module Sysfs = struct warn "Failed to obtain list of drivers from sysfs"; [] - let get_driver_version driver () = - try - Some (String.trim (Xapi_stdext_unix.Unixext.string_of_file ("/sys/bus/pci/drivers/" ^ driver ^ "/module/version"))) - with _ -> - warn "Failed to obtain driver version from sysfs"; - None - let getpath dev attr = Printf.sprintf "/sys/class/net/%s/%s" dev attr diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 5ff149b1d..7d3342581 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -25,7 +25,6 @@ type context = unit let network_conf = ref "/etc/xcp/network.conf" let config : config_t ref = ref Network_config.empty_config let backend_kind = ref Openvswitch -let enic_workaround_until_version = ref "2.3.0.30" let legacy_management_interface_start () = try @@ -95,30 +94,12 @@ let set_dns_interface _dbg name = debug "Setting DNS interface to %s" name; config := {!config with dns_interface = Some name} -(* Returns `true` if vs1 is older than vs2 *) -let is_older_version vs1 vs2 () = - try - let list_of_version vs = List.map int_of_string (Astring.String.cuts ~empty:false ~sep:"." vs) in - let rec loop vs1' vs2' = - match vs1', vs2' with - | [], _ | _, [] -> false - | a :: _, b :: _ when a < b -> true - | _ :: tl1, _ :: tl2 -> loop tl1 tl2 - in - loop (list_of_version vs1) (list_of_version vs2) - with _ -> - warn "Failed to compare driver version."; - false - (* The enic driver is for Cisco UCS devices. The current driver adds VLAN0 headers * to all incoming packets, which confuses certain guests OSes. The workaround * constitutes adding a VLAN0 Linux device to strip those headers again. *) let need_enic_workaround () = - !backend_kind = Bridge && List.mem "enic" (Sysfs.list_drivers ()) && (!enic_workaround_until_version <> "") && ( - match Sysfs.get_driver_version "enic" () with - | Some vs -> (is_older_version vs !enic_workaround_until_version ()) - | None -> false ) + !backend_kind = Bridge && List.mem "enic" (Sysfs.list_drivers ()) module Sriov = struct open S.Sriov diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 08f6b26ae..13a2a64ef 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -50,7 +50,6 @@ let resources = [ let options = [ "monitor_whitelist", Arg.String (fun x -> Network_monitor_thread.monitor_whitelist := Astring.String.cuts ~empty:false ~sep:"," x), (fun () -> String.concat "," !Network_monitor_thread.monitor_whitelist), "List of prefixes of interface names that are to be monitored"; "mac-table-size", Arg.Set_int Network_utils.mac_table_size, (fun () -> string_of_int !Network_utils.mac_table_size), "Default value for the mac-table-size openvswitch parameter (see ovs-vswitchd.conf.db.5)"; - "enic-workaround-until-version", Arg.Set_string Network_server.enic_workaround_until_version, (fun () -> !Network_server.enic_workaround_until_version), "The version till enic driver workaround will be applied or the version set to an empty string for not applying the workaround."; "pvs-proxy-socket", Arg.Set_string Network_server.PVS_proxy.path, (fun () -> !Network_server.PVS_proxy.path), "Path to the Unix domain socket for the PVS-proxy daemon"; "igmp-query-maxresp-time", Arg.Set_string Network_utils.igmp_query_maxresp_time, (fun () -> !Network_utils.igmp_query_maxresp_time), "Maximum Response Time in IGMP Query message to send"; "enable-ipv6-mcast-snooping", Arg.Bool (fun x -> Network_utils.enable_ipv6_mcast_snooping := x), (fun () -> string_of_bool !Network_utils.enable_ipv6_mcast_snooping), "IPv6 multicast snooping toggle"; From 4e1aea825fda6e387d4ee6ae34b87e2fb12ba60e Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Thu, 21 Feb 2019 15:38:46 +0000 Subject: [PATCH 223/260] CA-311211: Fix destroy_existing_vlan_bridge when enic workaround is enabled The function `destroy_existing_vlan_bridge` is called from `Bridge.create` if the bridge to be created is for a VLAN. The purpose is to get rid of any existing bridge for the same VLAN but with a different name. This was not working properly if case the enic workaround is in place, and the Linux bridge backend is used. The main use of this is installing a host with the management interface on a VLAN, where early in the host boot process, xcp-networkd creates a temporary bridge for the VLAN, called `xentemp`. This is because xcp-networkd does not yet know the final name of the VLAN bridge, which is determined later by xapi. When firstboot scripts run, a VLAN is created through xapi, with a new bridge name that is meant to replace the `xentemp` bridge. For example, for VLAN 123, the output of `brctl show` would be like this after xcp-network has started: bridge name bridge id STP enabled interfaces xenbr0 8000.0cc47ae6872c no eth0 xentemp 8000.0cc47ae6872d no eth0.123 The desired state after the firstboot scripts run is: bridge name bridge id STP enabled interfaces xenbr0 8000.0cc47ae6872c no eth0 xapi0 8000.0cc47ae6872d no eth0.123 Now, the problem occurred when running on a Cisco UCS host, with the "enic workaround" enabled. What happens then, is that not the eth0, but a VLAN0 device eth0.0 is added to the "parent" bridge xenbr0: bridge name bridge id STP enabled interfaces xenbr0 8000.0cc47ae6872c no eth0.0 xentemp 8000.0cc47ae6872d no eth0.123 The function `destroy_existing_vlan_bridge` did not take this into account. It is fixed by push the call to this function further down into `Bridge.create`, below the point where the enic workaround has been dealt with. It turned out easier to split the function into separate OVS and Linux bridge versions. Signed-off-by: Rob Hoes --- networkd/network_server.ml | 82 ++++++++++++++++++-------------------- 1 file changed, 39 insertions(+), 43 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 7d3342581..403ce7f36 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -572,48 +572,43 @@ module Bridge = struct | Bridge -> Sysfs.get_all_bridges () ) () - let destroy_existing_vlan_bridge name (parent, vlan) = - begin match !backend_kind with - | Openvswitch -> - let bridges = - let raw = Ovs.vsctl ["--bare"; "-f"; "table"; "--"; "--columns=name"; "find"; "port"; "fake_bridge=true"; "tag=" ^ (string_of_int vlan)] in - if raw <> "" then Astring.String.cuts ~empty:false ~sep:"\n" (String.trim raw) else [] - in - let existing_bridges = - List.filter ( fun bridge -> - match Ovs.bridge_to_vlan bridge with - | Some (p, v) -> p = parent && v = vlan - | None -> false - ) bridges in - List.iter (fun bridge -> - if bridge <> name then begin - debug "Destroying existing bridge %s" bridge; - remove_config bridge; - ignore (Ovs.destroy_bridge bridge) - end - ) existing_bridges - | Bridge -> - let ifaces = Sysfs.bridge_to_interfaces parent in - let existing_bridges = - match List.filter (fun (_, tag, iface) -> tag = vlan && List.mem iface ifaces) (Proc.get_vlans ()) with - | [] -> [] - | (vlan_iface, _, _) :: _ -> - List.filter (fun bridge -> - List.mem vlan_iface (Sysfs.bridge_to_interfaces bridge) - ) (Sysfs.get_all_bridges ()) - in - List.iter (fun bridge -> - if bridge <> name then begin - debug "Destroying existing bridge %s" bridge; - Interface.bring_down "Destroying existing bridge" bridge; - remove_config bridge; - List.iter (fun dev -> - Brctl.destroy_port bridge dev; - ) (Sysfs.bridge_to_interfaces bridge); - ignore (Brctl.destroy_bridge bridge) - end - ) existing_bridges - end + (* Destroy any existing OVS bridge that isn't the "wanted bridge" and has the + * given VLAN on it. *) + let destroy_existing_vlan_ovs_bridge wanted_bridge (parent, vlan) = + let vlan_bridges = + let raw = Ovs.vsctl ["--bare"; "-f"; "table"; "--"; "--columns=name"; "find"; "port"; "fake_bridge=true"; "tag=" ^ (string_of_int vlan)] in + if raw <> "" then Astring.String.cuts ~empty:false ~sep:"\n" (String.trim raw) else [] + in + let existing_bridges = + List.filter ( fun bridge -> + match Ovs.bridge_to_vlan bridge with + | Some (p, v) -> p = parent && v = vlan + | None -> false + ) vlan_bridges in + List.iter (fun bridge -> + if bridge <> wanted_bridge then begin + debug "Destroying existing bridge %s" bridge; + remove_config bridge; + ignore (Ovs.destroy_bridge bridge) + end + ) existing_bridges + + (* Destroy any existing Linux bridge that isn't the "wanted bridge" and has the + * given VLAN on it. *) + let destroy_existing_vlan_linux_bridge dbg wanted_bridge vlan_device = + List.iter (fun bridge -> + if bridge <> wanted_bridge then + let ifaces_on_bridge = Sysfs.bridge_to_interfaces bridge in + if List.mem vlan_device ifaces_on_bridge then begin + debug "Destroying existing bridge %s" bridge; + Interface.bring_down dbg bridge; + remove_config bridge; + List.iter (fun dev -> + Brctl.destroy_port bridge dev; + ) ifaces_on_bridge; + ignore (Brctl.destroy_bridge bridge) + end + ) (Sysfs.get_all_bridges ()) let create dbg vlan mac igmp_snooping other_config name = Debug.with_thread_associated dbg (fun () -> @@ -624,7 +619,6 @@ module Bridge = struct | None -> "" | Some (parent, vlan) -> Printf.sprintf " (VLAN %d on bridge %s)" vlan parent ); - Xapi_stdext_monadic.Opt.iter (destroy_existing_vlan_bridge name) vlan; update_config name {(get_config name) with vlan; bridge_mac=mac; igmp_snooping; other_config}; begin match !backend_kind with | Openvswitch -> @@ -668,6 +662,7 @@ module Bridge = struct None) in let old_igmp_snooping = Ovs.get_mcast_snooping_enable ~name in + Xapi_stdext_monadic.Opt.iter (destroy_existing_vlan_ovs_bridge name) vlan; ignore (Ovs.create_bridge ?mac ~fail_mode ?external_id ?disable_in_band ?igmp_snooping vlan vlan_bug_workaround name); if igmp_snooping = Some true && not old_igmp_snooping then @@ -696,6 +691,7 @@ module Bridge = struct parent_bridge_interface in let vlan_name = Ip.vlan_name parent_interface vlan in + destroy_existing_vlan_linux_bridge dbg name vlan_name; (* Check if the VLAN is already in use by something else *) List.iter (fun (device, vlan', parent') -> (* A device for the same VLAN (parent + tag), but with a different From 82354a8b13a7dee53b4846779ebb19e772669d19 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Wed, 5 Jun 2019 12:07:18 +0800 Subject: [PATCH 224/260] CA-320563: xcp-networkd: fix the regex match for PCI BDF string PCI BDF format: up to 256 buses, each with up to 32 devices, each supporting eight functions. This commit fixes the regex match to include hex strings. Signed-off-by: Ming Lu --- lib/network_utils.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 26204b4fa..9536b9f02 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -246,7 +246,7 @@ module Sysfs = struct try Sys.readdir ("/sys/bus/pci/drivers/" ^ driver) |> Array.to_list - |> List.filter (Re.execp (Re.Perl.compile_pat "\\d+:\\d+:\\d+\\.\\d+")) + |> List.filter (Re.execp (Re.Perl.compile_pat "\\d+:[a-f\\d]+:[a-f\\d]+\\.\\d+")) |> List.length with _ -> 0 From b76b002c5425d816674f9086ee04cc7e29056857 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Wed, 5 Jun 2019 12:07:18 +0800 Subject: [PATCH 225/260] CA-320563: re-submit for missing change on regex PCI BDF format: up to 256 buses, each with up to 32 devices, each supporting eight functions. This commit fixes the regex match to include hex strings. Signed-off-by: Ming Lu --- lib/network_utils.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 9536b9f02..dc898513b 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -246,7 +246,7 @@ module Sysfs = struct try Sys.readdir ("/sys/bus/pci/drivers/" ^ driver) |> Array.to_list - |> List.filter (Re.execp (Re.Perl.compile_pat "\\d+:[a-f\\d]+:[a-f\\d]+\\.\\d+")) + |> List.filter (Re.execp (Re.Perl.compile_pat {|\d+:[a-f\d]+:[a-f\d]+\.\d|})) |> List.length with _ -> 0 From 75a4c5d51862dd466f417f3f86eb5e04e24b1dac Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 25 Jun 2019 10:47:15 +0100 Subject: [PATCH 226/260] Extend the naughty DHCP-server workaround to DNS See aead1477. Signed-off-by: Rob Hoes --- lib/network_utils.ml | 19 +++++++++++++------ networkd/network_server.ml | 10 +--------- 2 files changed, 14 insertions(+), 15 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index dc898513b..00021aa82 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -743,7 +743,11 @@ module Dhclient = struct then (debug "%s is the default gateway interface" interface; ["routers"]) else (debug "%s is NOT the default gateway interface" interface; []) in - let set_dns = if List.mem `set_dns options then ["domain-name"; "domain-name-servers"] else [] in + let set_dns = + if List.mem (`dns interface) options + then (debug "%s is the DNS interface" interface; ["domain-name"; "domain-name-servers"]) + else (debug "%s is NOT the DNS interface" interface; []) + in let request = minimal @ set_gateway @ set_dns in Printf.sprintf "interface \"%s\" {\n request %s;\n}\n" interface (String.concat ", " request) @@ -760,19 +764,22 @@ module Dhclient = struct (* This prevents the default route being set erroneously on CentOS *) (* Normally this wouldn't happen as we're not requesting routers, *) (* but some buggy DHCP servers ignore this *) + (* Same story for DNS! *) (* See CA-137892 *) let gw_opt = List.fold_left (fun l x -> match x with | `gateway y -> ["-e"; "GATEWAYDEV="^y] | _ -> l) [] options in + let dns_opt = if List.mem (`dns interface) options then [] else ["-e"; "PEERDNS=no"] in write_conf_file ~ipv6 interface options; let ipv6' = if ipv6 then ["-6"] else [] in - call_script ~timeout:None dhclient (ipv6' @ gw_opt @ ["-q"; - "-pf"; pid_file ~ipv6 interface; - "-lf"; lease_file ~ipv6 interface; - "-cf"; conf_file ~ipv6 interface; - interface]) + call_script ~timeout:None dhclient (ipv6' @ gw_opt @ dns_opt @ + ["-q"; + "-pf"; pid_file ~ipv6 interface; + "-lf"; lease_file ~ipv6 interface; + "-cf"; conf_file ~ipv6 interface; + interface]) let stop ?(ipv6=false) interface = try diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 403ce7f36..9032644fa 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -250,15 +250,7 @@ module Interface = struct | DHCP4 -> let open Xapi_stdext_monadic in let gateway = Opt.default [] (Opt.map (fun n -> [`gateway n]) !config.gateway_interface) in - let dns = - if !config.dns_interface = None || !config.dns_interface = Some name then begin - debug "%s is the DNS interface" name; - [`set_dns] - end else begin - debug "%s is NOT the DNS interface" name; - [] - end - in + let dns = Opt.default [] (Opt.map (fun n -> [`dns n]) !config.dns_interface) in let options = gateway @ dns in Dhclient.ensure_running name options | Static4 addrs -> From 65a652ff896043f6f7c1e4a135e9d5840247e336 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Mon, 15 Jul 2019 15:45:15 +0100 Subject: [PATCH 227/260] CA-323523: Ensure that dhclients get restarted when gateway/DNS changes Recent commit 75a4c5d5 changed the `options` argument to `Dhclient.write_conf_file`, but failed to update one of its callers, in `set_gateway_interface`. This meant that dhclient did not get restarted when necessary as a result of configuration changes. Rather than fixing the bad function call, this patch changes the code to be more robust. When starting a `dhclient` process for an interface that requires configuration by DHCP, the function `Dhclient.ensure_running` writes a configuration file to disk and passes its path to `dhclient` as a command line argument. The purpose of saving the configuration is to make `Dhclient.ensure_running` idempotent. When called, the function checks if a `dhclient` process is already running for the given interface, and if the last used configuration is identical to the newly requested one. If so, it leaves the process alone to cause minimal disturbance to the system. An interesting use case is changing the default gateway to another interface, and then back to the original interface (using `set_gateway_interface` and `Interface.make_config` twice). The first change properly updates the gateway, but the change back to the original interface doesn't end up restarting `dhclient` to switch the gateway back. This was addressed by rewriting the conf file of the gateway interface when changing it, in `set_gateway_interface` (see 637db588). Now, is seems wrong that `set_dns_interface`, which is a function with a very similar purpose to `set_gateway_interface`, does not rewrite conf files like `set_gateway_interface` does. Fixing that, however, could lead to the two functions interfering with each other. Therefore, rather than trying to update the conf file, we just delete it so that it will definitely be correctly regenerated later (and do this for both `set_*_interface` functions). Signed-off-by: Rob Hoes --- lib/network_utils.ml | 6 ++++++ networkd/network_server.ml | 25 +++++++++++++++---------- 2 files changed, 21 insertions(+), 10 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 00021aa82..a03e7f60a 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -759,6 +759,12 @@ module Dhclient = struct let conf = generate_conf ~ipv6 interface options in Xapi_stdext_unix.Unixext.write_string_to_file (conf_file ~ipv6 interface) conf + let remove_conf_file ?(ipv6=false) interface = + let file = conf_file ~ipv6 interface in + try + Unix.unlink file + with _ -> () + let start ?(ipv6=false) interface options = (* If we have a gateway interface, pass it to dhclient-script via -e *) (* This prevents the default route being set erroneously on CentOS *) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 9032644fa..44f0f09a2 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -74,23 +74,28 @@ let reset_state () = config := Network_config.read_management_conf () let set_gateway_interface _dbg name = - (* Update dhclient conf for interface on changing default gateway. - * If new default gateway is not same as gateway_interface from networkd.db then - * we need to remove gateway information from gateway_interface *) + (* Remove dhclient conf (if any) for the old and new gateway interfaces. + * This ensures that dhclient gets restarted with an updated conf file when + * necessary. *) begin match !config.gateway_interface with - | Some gateway_iface when name <> gateway_iface -> - let opts = - match !config.dns_interface with - | Some dns_iface when gateway_iface = dns_iface -> [`set_dns] - | _ -> [] - in - Dhclient.write_conf_file gateway_iface opts + | Some old_iface when name <> old_iface -> + Dhclient.remove_conf_file name; + Dhclient.remove_conf_file old_iface | _ -> () end; debug "Setting gateway interface to %s" name; config := {!config with gateway_interface = Some name} let set_dns_interface _dbg name = + (* Remove dhclient conf (if any) for the old and new DNS interfaces. + * This ensures that dhclient gets restarted with an updated conf file when + * necessary. *) + begin match !config.dns_interface with + | Some old_iface when name <> old_iface -> + Dhclient.remove_conf_file name; + Dhclient.remove_conf_file old_iface + | _ -> () + end; debug "Setting DNS interface to %s" name; config := {!config with dns_interface = Some name} From af0b2bbecb86d13bd47264881c050a4ba47bf144 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 16 Jul 2019 10:49:41 +0100 Subject: [PATCH 228/260] CA-323523: Restrict the interface of the `Dhclient` module Signed-off-by: Rob Hoes --- lib/network_utils.ml | 12 +++++++++++- networkd/network_server.ml | 2 +- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index a03e7f60a..7c0145396 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -722,7 +722,17 @@ module Linux_bonding = struct error "Bond %s does not exist; cannot set properties" master end -module Dhclient = struct +module Dhclient : +sig + type interface = string + val remove_conf_file : ?ipv6:bool -> interface -> unit + val is_running : ?ipv6:bool -> interface -> bool + val stop : ?ipv6:bool -> interface -> unit + val ensure_running : ?ipv6:bool -> interface -> [> `dns of string | `gateway of string ] list -> unit +end = +struct + type interface = string + let pid_file ?(ipv6=false) interface = let ipv6' = if ipv6 then "6" else "" in Printf.sprintf "/var/run/dhclient%s-%s.pid" ipv6' interface diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 44f0f09a2..fa0a359f1 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -327,7 +327,7 @@ module Interface = struct Sysctl.set_ipv6_autoconf name false; Ip.flush_ip_addr ~ipv6:true name; Ip.set_ipv6_link_local_addr name; - ignore (Dhclient.start ~ipv6:true name []) + ignore (Dhclient.ensure_running ~ipv6:true name []) | Autoconf6 -> if Dhclient.is_running ~ipv6:true name then ignore (Dhclient.stop ~ipv6:true name); From 6a85f86f098d1e76dbee9c9f6a0208d0d47a9f24 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 16 Jul 2019 11:21:36 +0100 Subject: [PATCH 229/260] CA-323523: Always stop any dhclient process before destroying a bridge Signed-off-by: Rob Hoes --- networkd/network_server.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index fa0a359f1..5899c9f8c 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -571,7 +571,7 @@ module Bridge = struct (* Destroy any existing OVS bridge that isn't the "wanted bridge" and has the * given VLAN on it. *) - let destroy_existing_vlan_ovs_bridge wanted_bridge (parent, vlan) = + let destroy_existing_vlan_ovs_bridge dbg wanted_bridge (parent, vlan) = let vlan_bridges = let raw = Ovs.vsctl ["--bare"; "-f"; "table"; "--"; "--columns=name"; "find"; "port"; "fake_bridge=true"; "tag=" ^ (string_of_int vlan)] in if raw <> "" then Astring.String.cuts ~empty:false ~sep:"\n" (String.trim raw) else [] @@ -586,6 +586,7 @@ module Bridge = struct if bridge <> wanted_bridge then begin debug "Destroying existing bridge %s" bridge; remove_config bridge; + Interface.set_ipv4_conf dbg bridge None4; ignore (Ovs.destroy_bridge bridge) end ) existing_bridges @@ -600,6 +601,7 @@ module Bridge = struct debug "Destroying existing bridge %s" bridge; Interface.bring_down dbg bridge; remove_config bridge; + Interface.set_ipv4_conf dbg bridge None4; List.iter (fun dev -> Brctl.destroy_port bridge dev; ) ifaces_on_bridge; @@ -659,7 +661,7 @@ module Bridge = struct None) in let old_igmp_snooping = Ovs.get_mcast_snooping_enable ~name in - Xapi_stdext_monadic.Opt.iter (destroy_existing_vlan_ovs_bridge name) vlan; + Xapi_stdext_monadic.Opt.iter (destroy_existing_vlan_ovs_bridge dbg name) vlan; ignore (Ovs.create_bridge ?mac ~fail_mode ?external_id ?disable_in_band ?igmp_snooping vlan vlan_bug_workaround name); if igmp_snooping = Some true && not old_igmp_snooping then From eeb96882ed19270e02df8ff3b6b3b5298cf8b913 Mon Sep 17 00:00:00 2001 From: lippirk Date: Fri, 26 Jul 2019 14:24:55 +0100 Subject: [PATCH 230/260] CP-28368 Propagate test_highlevel ounit removal Signed-off-by: lippirk --- test/dune | 2 +- test/network_test.ml | 18 +++------ test/network_test_lacp_properties.ml | 59 +++++++++------------------- test/test_jsonrpc_client.ml | 11 ++---- 4 files changed, 30 insertions(+), 60 deletions(-) diff --git a/test/dune b/test/dune index ba5a912b8..791f9d2c8 100644 --- a/test/dune +++ b/test/dune @@ -1,9 +1,9 @@ (executable (name network_test) (libraries + alcotest astring networklibs - oUnit profiling xapi-test-utils) ) diff --git a/test/network_test.ml b/test/network_test.ml index 3d2ba46cc..61811d1a8 100644 --- a/test/network_test.ml +++ b/test/network_test.ml @@ -12,15 +12,9 @@ * GNU Lesser General Public License for more details. *) -open OUnit - -let base_suite = - "base_suite" >::: - [ - Network_test_lacp_properties.suite; - Test_jsonrpc_client.suite; - ] - -let _ = - Coverage.init "network_test"; - run_test_tt_main base_suite +let () = + Debug.log_to_stdout (); + Alcotest.run "base_suite" ( + Network_test_lacp_properties.suite @ + Test_jsonrpc_client.tests + ) diff --git a/test/network_test_lacp_properties.ml b/test/network_test_lacp_properties.ml index ef2ab0366..4e20de8cd 100644 --- a/test/network_test_lacp_properties.ml +++ b/test/network_test_lacp_properties.ml @@ -12,31 +12,16 @@ * GNU Lesser General Public License for more details. *) -open OUnit open Network_utils -(* Example of using OUnitDiff with a String Set *) -module StringDiff = -struct - type t = string - let compare = String.compare - let pp_printer = Format.pp_print_string - let pp_print_sep = OUnitDiff.pp_comma_separator -end - -module OSSet = OUnitDiff.SetMake(StringDiff) +let check_string_list = Alcotest.(check (list string)) +let to_test_string prefix ps = Format.sprintf "%s: %s" prefix (String.concat ";" ps) let run_bond_prop_test props c_props c_per_iface = let props, per_iface_props = Ovs.make_bond_properties "bond_test" props in - - let propset = OSSet.of_list props in - let correctset = OSSet.of_list c_props in - OSSet.assert_equal correctset propset ; - - let propset = OSSet.of_list per_iface_props in - let correctset = OSSet.of_list c_per_iface in - OSSet.assert_equal correctset propset + check_string_list (to_test_string "c_props" c_props) c_props props; + check_string_list (to_test_string "c_per_iface" c_per_iface) c_per_iface per_iface_props let test_lacp_timeout_prop arg () = let props = [ "mode", "lacp" ; "lacp-time", arg ; ] @@ -59,13 +44,8 @@ let test_lacp_aggregation_key arg () = Printf.sprintf "other-config:lacp-aggregation-key=\"%s\"" arg ; ] in - let propset = OSSet.of_list props in - let correctset = OSSet.of_list correct_props in - OSSet.assert_equal correctset propset ; - - let propset = OSSet.of_list per_iface_props in - let correctset = OSSet.of_list correct_iface_props in - OSSet.assert_equal correctset propset + check_string_list "lacp_aggregation_key_correct_props" correct_props props; + check_string_list "lacp_aggregation_key_correct_iface_props" correct_iface_props per_iface_props module OVS_Cli_test = struct include Ovs.Cli @@ -76,7 +56,7 @@ module OVS_Cli_test = struct end (* XXX TODO write this test *) -let test_lacp_aggregation_key_vsctl arg () = skip_if true "Unimplemented" ; +let test_lacp_aggregation_key_vsctl arg () = let module Ovs = Ovs.Make(OVS_Cli_test) in let bond = "bond0" and ifaces = ["eth0"; "eth1"] @@ -88,10 +68,11 @@ let test_lacp_aggregation_key_vsctl arg () = skip_if true "Unimplemented" ; Ovs.create_bond bond ifaces bridge props |> ignore ; List.iter print_endline !OVS_Cli_test.vsctl_output ; print_endline answer ; - assert_bool "lacp_aggregation_key is passed to ovs-vsctl command" + (* todo: pass -> replace with bool *) + Alcotest.(check pass "lacp_aggregation_key is passed to ovs-vsctl command" true (List.exists (fun s -> (String.trim s) == answer) - !OVS_Cli_test.vsctl_output) + !OVS_Cli_test.vsctl_output)) (* Test case for bond_create with default lacp-{time,aggregation-key} settings. This should not call ovs-vsctl with unfinished key=value arguments. So we @@ -113,17 +94,15 @@ let test_lacp_defaults_bond_create () = List.exists (fun s -> String.*) List.iter (fun arg -> - assert_bool "key=value argument pairs can't have missing values" + Alcotest.(check bool "key=value argument pairs can't have missing values" true (let open Astring.String in - arg |> trim |> is_suffix ~affix:"=" |> not)) + arg |> trim |> is_suffix ~affix:"=" |> not))) !OVS_Cli_test.vsctl_output -let suite = - "lacp_properties" >::: - [ - "test_lacp_timeout_prop(slow)" >:: test_lacp_timeout_prop "slow"; - "test_lacp_timeout_prop(fast)" >:: test_lacp_timeout_prop "fast"; - "test_lacp_aggregation_key(42)" >:: test_lacp_aggregation_key "42"; - "test_lacp_aggregation_key_vsctl" >:: test_lacp_aggregation_key_vsctl "42"; - "test_lacp_defaults_bond_create" >:: test_lacp_defaults_bond_create; - ] +let suite = [ "test_lacp", [ "timeout_prop(slow)", `Quick, test_lacp_timeout_prop "slow"; + "timeout_prop(fast)", `Quick, test_lacp_timeout_prop "fast"; + "aggregation_key(42)", `Quick, test_lacp_aggregation_key "42"; + "aggregation_key_vsctl", `Quick, test_lacp_aggregation_key_vsctl "42"; + "defaults_bond_create", `Quick, test_lacp_defaults_bond_create; + ] + ] diff --git a/test/test_jsonrpc_client.ml b/test/test_jsonrpc_client.ml index b2f3c4e51..af6fd9dad 100644 --- a/test/test_jsonrpc_client.ml +++ b/test/test_jsonrpc_client.ml @@ -12,7 +12,6 @@ * GNU Lesser General Public License for more details. *) -open OUnit open Test_highlevel open Xapi_stdext_monadic.Either @@ -21,7 +20,7 @@ let dir = Filename.concat "test" "jsonrpc_files" let jsonrpc_printer : Rpc.t Test_printers.printer = Jsonrpc.to_string -module Input_json_object = Generic.Make (struct +module Input_json_object = Generic.MakeStateless (struct module Io = struct type input_t = string type output_t = (exn, Rpc.t) Xapi_stdext_monadic.Either.t @@ -51,7 +50,7 @@ module Input_json_object = Generic.Make (struct close_in fin; response - let tests = [ + let tests = `QuickAndAutoDocumented [ (* A file containing exactly one JSON object. *) (* It has got curly braces inside strings to make it interesting. *) "good_call.json", Right good_call; @@ -67,8 +66,6 @@ module Input_json_object = Generic.Make (struct ] end) -let suite = - "jsonrpc_client" >::: - [ - "input_json_object" >::: Input_json_object.tests; +let tests = + [ "json_rpc_client_input_json_object", Input_json_object.tests; ] From 290cce1046f3f3298035a8e237c6b5d3637fe1fb Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Thu, 1 Aug 2019 16:06:23 +0100 Subject: [PATCH 231/260] Remove calls to obsolete network scripts Signed-off-by: Rob Hoes --- networkd/network_server.ml | 27 +++++++-------------------- 1 file changed, 7 insertions(+), 20 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 5899c9f8c..82f151c6c 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -26,14 +26,6 @@ let network_conf = ref "/etc/xcp/network.conf" let config : config_t ref = ref Network_config.empty_config let backend_kind = ref Openvswitch -let legacy_management_interface_start () = - try - ignore (call_script "/opt/xensource/libexec/legacy-management-interface" ["start"]); - debug "Upgrade: brought up interfaces using the old script. Xapi will sync up soon." - with e -> - debug "Error while configuring the management interface using the old script: %s\n%s" - (Printexc.to_string e) (Printexc.get_backtrace ()) - let write_config () = try Network_config.write_config !config @@ -44,18 +36,13 @@ let read_config () = config := Network_config.read_config (); debug "Read configuration from networkd.db file." with Network_config.Read_error -> - (* No configuration file found. *) - (* Perhaps it is an upgrade from the pre-networkd era. If network.dbcache exists, try to configure the - * management interface using the old scripts. *) - if (try Unix.access (Filename.concat "/var/lib/xcp" "network.dbcache") [Unix.F_OK]; true with _ -> false) then - legacy_management_interface_start () - else - (* Try to get the initial network setup from the first-boot data written by the host installer. *) - try - config := Network_config.read_management_conf (); - debug "Read configuration from management.conf file." - with Network_config.Read_error -> - debug "Could not interpret the configuration in management.conf" + (* No configuration file found. Try to get the initial network setup from + * the first-boot data written by the host installer. *) + try + config := Network_config.read_management_conf (); + debug "Read configuration from management.conf file." + with Network_config.Read_error -> + debug "Could not interpret the configuration in management.conf" let on_shutdown signal = let dbg = "shutdown" in From c9d61af324e957ba2486bf133742a0e69703cd83 Mon Sep 17 00:00:00 2001 From: Zheng Li Date: Tue, 13 Aug 2019 15:13:49 +0100 Subject: [PATCH 232/260] CA-323765: preserve the "type" config when re-adding existing interfaces ... such as those pvsproxy ones which have type=internal. Signed-off-by: Zheng Li --- lib/network_utils.ml | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 7c0145396..52102cd2b 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -1127,6 +1127,12 @@ module Ovs = struct fork_script !inject_igmp_query_script (["--no-check-snooping-toggle"; "--max-resp-time"; !igmp_query_maxresp_time] @ bvifs' @ vvifs) with _ -> () + let create_port_arg ?ty name bridge = + let type_args = match ty with + | None | Some "" -> [] + | Some s -> ["--"; "set"; "interface"; name; Printf.sprintf "type=%s" s] in + ["--"; "--may-exist"; "add-port"; bridge; name] @ type_args + let create_bridge ?mac ?external_id ?disable_in_band ?igmp_snooping ~fail_mode vlan vlan_bug_workaround name = let vlan_arg = match vlan with | None -> [] @@ -1162,7 +1168,15 @@ module Ovs = struct in let vif_arg = let existing_vifs = List.filter (fun iface -> not (Sysfs.is_physical iface)) (bridge_to_interfaces name) in - List.flatten (List.map (fun vif -> ["--"; "--may-exist"; "add-port"; name; vif]) existing_vifs) + let ifaces_with_type = + let raw = vsctl ~log:false ["--bare"; "-f"; "table"; "--"; "--columns=name,type"; "find"; "interface"; {|type!=\"\"|}] in + let lines = Astring.String.cuts ~empty:false ~sep:"\n" (String.trim raw) in + let parse l = match Astring.String.cut ~sep:" " l with + | Some (k, v) -> let k' = String.trim k and v' = String.trim v in if k' = "" || v' = "" then None else Some(k', v') + | None -> None in + Xapi_stdext_std.Listext.List.filter_map parse lines + in + List.flatten (List.map (fun vif -> create_port_arg ?ty:(List.assoc_opt vif ifaces_with_type) vif name) existing_vifs) in let del_old_arg = if vlan <> None then @@ -1204,9 +1218,8 @@ module Ovs = struct [] let create_port ?(internal=false) name bridge = - let type_args = - if internal then ["--"; "set"; "interface"; name; "type=internal"] else [] in - vsctl (["--"; "--may-exist"; "add-port"; bridge; name] @ type_args) + let ty = if internal then Some "internal" else None in + vsctl (create_port_arg ?ty name bridge) let destroy_port name = vsctl ["--"; "--with-iface"; "--if-exists"; "del-port"; name] From d53159190290cd64f072789d19f65d23e122f19b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 13 Aug 2019 18:03:41 +0100 Subject: [PATCH 233/260] CA-324959: do not loose DNS settings after a network reset MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Equivalent to 2a194695257657407327a96bcc097f24d4dfb3f8 from LCM branch. Signed-off-by: Edwin Török --- lib/network_config.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/network_config.ml b/lib/network_config.ml index 1f9c4ba43..ddffbf001 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -67,7 +67,7 @@ let read_management_conf () = bridge in let mac = Network_utils.Ip.get_mac device in - let ipv4_conf, ipv4_gateway, _dns = + let ipv4_conf, ipv4_gateway, dns = match List.assoc "MODE" args with | "static" -> let ip = List.assoc "IP" args |> Unix.inet_addr_of_string in @@ -93,7 +93,7 @@ let read_management_conf () = DHCP4, None, ([], []) in let phy_interface = {default_interface with persistent_i = true} in - let bridge_interface = {default_interface with ipv4_conf; ipv4_gateway; persistent_i = true} in + let bridge_interface = {default_interface with ipv4_conf; ipv4_gateway; persistent_i = true; dns} in let interface_config, bridge_config = let primary_bridge_conf = {default_bridge with bridge_mac = Some mac; From 16839bf44f488dad3f600545e3dfaaa514706883 Mon Sep 17 00:00:00 2001 From: Robin Lee Date: Tue, 11 Jun 2019 18:29:44 +0800 Subject: [PATCH 234/260] Restart 'ip monitor address' process if it quitted If the 'ip monitor address' process quitted for some reason, xcp-networkd will be logging in an infinite loop and soon eat up the /var/log space. Signed-off-by: Robin Lee --- networkd/network_monitor_thread.ml | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index d460ef246..3fc124faf 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -278,7 +278,7 @@ let clear_input fd = loop (); Unix.clear_nonblock fd -let ip_watcher () = +let rec ip_watcher () = let cmd = Network_utils.iproute2 in let args = ["monitor"; "address"] in let readme, writeme = Unix.pipe () in @@ -299,12 +299,26 @@ let ip_watcher () = end; loop () in + let restart_ip_watcher () = begin + Unix.close readme; + Thread.delay 5.0; + ip_watcher (); + end + in while true do try info "(Re)started IP watcher thread"; loop () with e -> - warn "Error in IP watcher: %s\n%s" (Printexc.to_string e) (Printexc.get_backtrace ()) + warn "Error in IP watcher: %s\n%s" (Printexc.to_string e) (Printexc.get_backtrace ()); + match !watcher_pid with + | None -> restart_ip_watcher () + | Some pid -> + let quitted, _ = Forkhelpers.waitpid_nohang pid in + if quitted <> 0 then begin + warn "address monitoring process quitted, try to restart it"; + restart_ip_watcher () + end done let start () = From 41d6a29707592d3f8ef7853aad616e2a6c4dab00 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Thu, 14 Nov 2019 10:05:26 +0000 Subject: [PATCH 235/260] Ovs.create_bridge: whitespace in vsctl call Signed-off-by: Rob Hoes --- lib/network_utils.ml | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 52102cd2b..a3deb0492 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -1204,8 +1204,20 @@ module Ovs = struct ["--"; "set"; "bridge"; name; "other_config:mcast-snooping-disable-flood-unregistered=" ^ (string_of_bool !mcast_snooping_disable_flood_unregistered)] | _ -> [] in - vsctl (del_old_arg @ ["--"; "--may-exist"; "add-br"; name] @ - vlan_arg @ mac_arg @ fail_mode_arg @ disable_in_band_arg @ external_id_arg @ vif_arg @ set_mac_table_size @ set_igmp_snooping @ set_ipv6_igmp_snooping @ disable_flood_unregistered) + vsctl ( + del_old_arg + @ ["--"; "--may-exist"; "add-br"; name] + @ vlan_arg + @ mac_arg + @ fail_mode_arg + @ disable_in_band_arg + @ external_id_arg + @ vif_arg + @ set_mac_table_size + @ set_igmp_snooping + @ set_ipv6_igmp_snooping + @ disable_flood_unregistered + ) let destroy_bridge name = vsctl ["--"; "--if-exists"; "del-br"; name] From ef3aed4d8bc35e247bd48033dac2c0b29b4a7195 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Thu, 14 Nov 2019 10:09:22 +0000 Subject: [PATCH 236/260] CA-329442: Avoid recreating bridges unless absolutely necessary When asked to create a bridge, when need to destroy an existing bridge with the same name _only_ when a the existing bridge is a "real" (non-VLAN) bridge, and the new one is a "fake" VLAN bridge. Otherwise, the function `OVS.create_bridge`, which must be idempotent, should leave the bridge alone to as to not disturb the system. Signed-off-by: Rob Hoes --- lib/network_utils.ml | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index a3deb0492..4e1c6d78a 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -1179,8 +1179,16 @@ module Ovs = struct List.flatten (List.map (fun vif -> create_port_arg ?ty:(List.assoc_opt vif ifaces_with_type) vif name) existing_vifs) in let del_old_arg = - if vlan <> None then - (* This is to handle the case that a "real" bridge (not a "fake" VLAN bridge) already exists *) + let real_bridge_exists () = + try + (* `ovs-vsctl br-to-parent ` returns if is a current "real" bridge *) + vsctl ~log:false ["br-to-parent"; name] |> String.trim = name + with _ -> false + in + if vlan <> None && real_bridge_exists () then + (* This is to handle the case that a "real" bridge (not a "fake" VLAN bridge) + already exists, while we need to create a VLAN bridge with the same name. + The bridge will be destroyed and recreated, and the interfaces on it are put back. *) ["--"; "--if-exists"; "del-br"; name] else [] From 1dd3f3d44817aafce14be3dbd9e0b32c30167a68 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 6 Mar 2020 14:34:39 +0000 Subject: [PATCH 237/260] Use common Travis CI configuration MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- .travis.yml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/.travis.yml b/.travis.yml index a6b10e8aa..ec363c8e5 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,12 +1,12 @@ language: c -sudo: required service: docker -install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh +install: + - wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh + - wget https://raw.githubusercontent.com/xapi-project/xs-opam/master/tools/xs-opam-ci.env + - source xs-opam-ci.env script: bash -ex .travis-docker.sh env: global: - - PACKAGE="xapi-networkd" - PINS="xapi-networkd:." - - BASE_REMOTE="https://github.com/xapi-project/xs-opam.git" - matrix: - - DISTRO="debian-9-ocaml-4.07" + jobs: + - PACKAGE="xapi-networkd" From cf86276055c05033ac6189c497c2b2ab2e32a5eb Mon Sep 17 00:00:00 2001 From: John Else Date: Mon, 6 Apr 2020 17:29:38 +0100 Subject: [PATCH 238/260] Make dhclient send our hostname to the DHCP server This generates a config file of the form: ``` interface "xenbr0" { send host-name = gethostname(); request subnet-mask, broadcast-address, time-offset, host-name, nis-domain, nis-servers, ntp-servers, interface-mtu, routers, domain-name, domain-name-servers; } ``` Also fixes test build. Signed-off-by: John Else --- lib/network_utils.ml | 4 +++- test/network_test_lacp_properties.ml | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 4e1c6d78a..9b275ad59 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -746,6 +746,7 @@ struct Filename.concat "/var/lib/xcp" (Printf.sprintf "dhclient%s-%s.conf" ipv6' interface) let[@warning "-27"] generate_conf ?(ipv6=false) interface options = + let send = "host-name = gethostname()" in let minimal = ["subnet-mask"; "broadcast-address"; "time-offset"; "host-name"; "nis-domain"; "nis-servers"; "ntp-servers"; "interface-mtu"] in let set_gateway = @@ -759,7 +760,8 @@ struct else (debug "%s is NOT the DNS interface" interface; []) in let request = minimal @ set_gateway @ set_dns in - Printf.sprintf "interface \"%s\" {\n request %s;\n}\n" interface (String.concat ", " request) + Printf.sprintf "interface \"%s\" {\n send %s;\n request %s;\n}\n" + interface send (String.concat ", " request) let read_conf_file ?(ipv6=false) interface = let file = conf_file ~ipv6 interface in diff --git a/test/network_test_lacp_properties.ml b/test/network_test_lacp_properties.ml index 4e20de8cd..ab53998bb 100644 --- a/test/network_test_lacp_properties.ml +++ b/test/network_test_lacp_properties.ml @@ -50,7 +50,7 @@ let test_lacp_aggregation_key arg () = module OVS_Cli_test = struct include Ovs.Cli let vsctl_output = ref [] - let vsctl ?log args = + let vsctl ?log:_ args = vsctl_output := args ; String.concat " " args end From 497dfaedc34f6bc563ab4e148c3382f9950519d4 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 14 May 2020 10:15:05 +0100 Subject: [PATCH 239/260] Maintenance: format code with ocamlformat Signed-off-by: Pau Ruiz Safont --- .ocamlformat | 9 + Makefile | 8 +- dune-project | 3 +- lib/jsonrpc_client.ml | 134 +- lib/jsonrpc_client.mli | 11 +- lib/network_config.ml | 276 ++-- lib/network_utils.ml | 1638 +++++++++++++++--------- networkd/network_monitor.ml | 6 +- networkd/network_monitor_thread.ml | 549 ++++---- networkd/network_server.ml | 1750 ++++++++++++++++---------- networkd/networkd.ml | 319 +++-- networkd_db/networkd_db.ml | 165 ++- profiling/coverage.ml | 10 +- profiling/coverage.mli | 4 +- test/jsonrpc_dummy.ml | 19 +- test/network_test.ml | 8 +- test/network_test_lacp_properties.ml | 104 +- test/test_jsonrpc_client.ml | 87 +- 18 files changed, 3110 insertions(+), 1990 deletions(-) create mode 100644 .ocamlformat diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 000000000..b4d356a77 --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,9 @@ +profile=ocamlformat +version=0.14.1 +indicate-multiline-delimiters=closing-on-separate-line +if-then-else=fit-or-vertical +dock-collection-brackets=true +break-struct=natural +break-separators=before +break-infix=fit-or-vertical +break-infix-before-func=false diff --git a/Makefile b/Makefile index 20e6f711f..acabfcf80 100644 --- a/Makefile +++ b/Makefile @@ -3,8 +3,7 @@ SBINDIR ?= /usr/sbin MANDIR ?= /usr/share/man/man1 PROFILE=release - -.PHONY: release build install uninstall clean test doc reindent +.PHONY: release build install uninstall clean test doc format release: dune build @install @networkd/man --profile=$(PROFILE) @@ -40,5 +39,6 @@ gprof: doc: dune build @doc --profile=$(PROFILE) -reindent: - ocp-indent --inplace **/*.ml* +# requires ocamlformat +format: + dune build @fmt --auto-promote diff --git a/dune-project b/dune-project index f9337290c..cd5e890ae 100644 --- a/dune-project +++ b/dune-project @@ -1 +1,2 @@ -(lang dune 1.4) +(lang dune 1.11) +(using fmt 1.2 (enabled_for ocaml)) diff --git a/lib/jsonrpc_client.ml b/lib/jsonrpc_client.ml index 133498ed5..64092b51a 100644 --- a/lib/jsonrpc_client.ml +++ b/lib/jsonrpc_client.ml @@ -14,61 +14,73 @@ (* JSON-RPC Client *) -module D = Debug.Make(struct let name = "jsonrpc_client" end) +module D = Debug.Make (struct let name = "jsonrpc_client" end) + open D exception Timeout + exception Read_error let json_rpc_max_len = ref 65536 (* Arbitrary maximum length of RPC response *) -let json_rpc_read_timeout = ref 60000000000L (* timeout value in ns when reading RPC response *) -let json_rpc_write_timeout = ref 60000000000L (* timeout value in ns when writing RPC request *) -let to_s s = (Int64.to_float s) *. 1e-9 +let json_rpc_read_timeout = ref 60000000000L + +(* timeout value in ns when reading RPC response *) + +let json_rpc_write_timeout = ref 60000000000L + +(* timeout value in ns when writing RPC request *) + +let to_s s = Int64.to_float s *. 1e-9 (* Read the entire contents of the fd, of unknown length *) let timeout_read fd timeout = let buf = Buffer.create !json_rpc_max_len in let read_start = Mtime_clock.counter () in - let get_total_used_time () = Mtime.Span.to_uint64_ns (Mtime_clock.count read_start) in + let get_total_used_time () = + Mtime.Span.to_uint64_ns (Mtime_clock.count read_start) + in let rec inner max_time max_bytes = - let (ready_to_read, _, _) = try Unix.select [fd] [] [] (to_s max_time) with + let ready_to_read, _, _ = + try Unix.select [fd] [] [] (to_s max_time) + with (* in case the unix.select call fails in situation like interrupt *) - | Unix.Unix_error(Unix.EINTR,_,_) -> [], [], [] + | Unix.Unix_error (Unix.EINTR, _, _) -> + ([], [], []) in (* This is not accurate the calculate time just for the select part. However, we * think the read time will be minor comparing to the scale of tens of seconds. * the current style will be much concise in code. *) - let remain_time = + let remain_time = let used_time = get_total_used_time () in Int64.sub timeout used_time in - if remain_time < 0L then - begin - debug "Timeout after read %d" (Buffer.length buf); - raise Timeout - end; + if remain_time < 0L then ( + debug "Timeout after read %d" (Buffer.length buf) ; + raise Timeout + ) ; if List.mem fd ready_to_read then - begin - let bytes = Bytes.make 4096 '\000' in - match Unix.read fd bytes 0 4096 with - | 0 -> Buffer.contents buf (* EOF *) - | n -> - if n > max_bytes then - begin - debug "exceeding maximum read limit %d, clear buffer" !json_rpc_max_len; - Buffer.clear buf; - raise Read_error - end - else - begin - Buffer.add_subbytes buf bytes 0 n; - inner remain_time (max_bytes - n) - end - | exception Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR),_,_) -> + let bytes = Bytes.make 4096 '\000' in + match Unix.read fd bytes 0 4096 with + | 0 -> + Buffer.contents buf (* EOF *) + | n -> + if n > max_bytes then ( + debug "exceeding maximum read limit %d, clear buffer" + !json_rpc_max_len ; + Buffer.clear buf ; + raise Read_error + ) else ( + Buffer.add_subbytes buf bytes 0 n ; + inner remain_time (max_bytes - n) + ) + | exception + Unix.Unix_error ((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR), _, _) + -> inner remain_time max_bytes - end - else inner remain_time max_bytes + else + inner remain_time max_bytes in inner timeout !json_rpc_max_len @@ -77,42 +89,50 @@ let timeout_read fd timeout = (* Writes into the file descriptor at the current cursor position. *) let timeout_write filedesc total_length data response_time = let write_start = Mtime_clock.counter () in - let get_total_used_time () = Mtime.Span.to_uint64_ns (Mtime_clock.count write_start) in + let get_total_used_time () = + Mtime.Span.to_uint64_ns (Mtime_clock.count write_start) + in let rec inner_write offset max_time = - let (_, ready_to_write, _) = try Unix.select [] [filedesc] [] (to_s max_time) with + let _, ready_to_write, _ = + try Unix.select [] [filedesc] [] (to_s max_time) + with (* in case the unix.select call fails in situation like interrupt *) - | Unix.Unix_error(Unix.EINTR,_,_) -> [], [], [] + | Unix.Unix_error (Unix.EINTR, _, _) -> + ([], [], []) in - let remain_time = + let remain_time = let used_time = get_total_used_time () in Int64.sub response_time used_time in - if remain_time < 0L then - begin - debug "Timeout to write %d at offset %d" total_length offset; - raise Timeout - end; - if List.mem filedesc ready_to_write then - begin - let length = total_length - offset in - let bytes_written = - (try Unix.single_write filedesc data offset length with - | Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR),_,_) -> 0) - in - let new_offset = offset + bytes_written in - if length = bytes_written then () - else inner_write new_offset remain_time - end - else inner_write offset remain_time + if remain_time < 0L then ( + debug "Timeout to write %d at offset %d" total_length offset ; + raise Timeout + ) ; + if List.mem filedesc ready_to_write then + let length = total_length - offset in + let bytes_written = + try Unix.single_write filedesc data offset length + with + | Unix.Unix_error ((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR), _, _) + -> + 0 + in + let new_offset = offset + bytes_written in + if length = bytes_written then + () + else + inner_write new_offset remain_time + else + inner_write offset remain_time in inner_write 0 response_time -let with_rpc ?(version=Jsonrpc.V2) ~path ~call () = +let with_rpc ?(version = Jsonrpc.V2) ~path ~call () = let uri = Uri.of_string (Printf.sprintf "file://%s" path) in Open_uri.with_open_uri uri (fun s -> - Unix.set_nonblock s; + Unix.set_nonblock s ; let req = Bytes.of_string (Jsonrpc.string_of_call ~version call) in - timeout_write s (Bytes.length req) req !json_rpc_write_timeout; + timeout_write s (Bytes.length req) req !json_rpc_write_timeout ; let res = timeout_read s !json_rpc_read_timeout in - debug "Response: %s" res; + debug "Response: %s" res ; Jsonrpc.response_of_string ~strict:false res) diff --git a/lib/jsonrpc_client.mli b/lib/jsonrpc_client.mli index ad785ad83..2f92337e5 100644 --- a/lib/jsonrpc_client.mli +++ b/lib/jsonrpc_client.mli @@ -13,15 +13,22 @@ *) exception Timeout + exception Read_error val json_rpc_max_len : int ref + val json_rpc_read_timeout : int64 ref + val json_rpc_write_timeout : int64 ref val timeout_read : Unix.file_descr -> int64 -> string +val with_rpc : + ?version:Jsonrpc.version + -> path:string + -> call:Rpc.call + -> unit + -> Rpc.response (** Do an JSON-RPC call to a server that is listening on a Unix domain * socket at the given path. *) -val with_rpc : ?version:Jsonrpc.version -> path:string -> call:Rpc.call -> unit -> Rpc.response - diff --git a/lib/network_config.ml b/lib/network_config.ml index ddffbf001..4381cbd6d 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -14,36 +14,52 @@ open Network_interface -module D = Debug.Make(struct let name = "network_config" end) +module D = Debug.Make (struct let name = "network_config" end) + open D exception Read_error + exception Write_error let empty_config = default_config let config_file_path = "/var/lib/xcp/networkd.db" -let temp_vlan = "xentemp" +let temp_vlan = "xentemp" -let bridge_naming_convention (device: string) = - if Astring.String.is_prefix ~affix:"eth" device - then ("xenbr" ^ (String.sub device 3 (String.length device - 3))) - else ("br" ^ device) +let bridge_naming_convention (device : string) = + if Astring.String.is_prefix ~affix:"eth" device then + "xenbr" ^ String.sub device 3 (String.length device - 3) + else + "br" ^ device let read_management_conf () = try - let management_conf = Xapi_stdext_unix.Unixext.string_of_file ("/etc/firstboot.d/data/management.conf") in - let args = Astring.String.cuts ~empty:false ~sep:"\n" (String.trim management_conf) in - let args = List.map (fun s -> - match (Astring.String.cuts ~sep:"=" s) with - | k :: [v] -> k, Astring.String.trim ~drop:((=) '\'') v - | _ -> "", "" - ) args in - debug "Firstboot file management.conf has: %s" (String.concat "; " (List.map (fun (k, v) -> k ^ "=" ^ v) args)); + let management_conf = + Xapi_stdext_unix.Unixext.string_of_file + "/etc/firstboot.d/data/management.conf" + in + let args = + Astring.String.cuts ~empty:false ~sep:"\n" (String.trim management_conf) + in + let args = + List.map + (fun s -> + match Astring.String.cuts ~sep:"=" s with + | [k; v] -> + (k, Astring.String.trim ~drop:(( = ) '\'') v) + | _ -> + ("", "")) + args + in + debug "Firstboot file management.conf has: %s" + (String.concat "; " (List.map (fun (k, v) -> k ^ "=" ^ v) args)) ; let device = List.assoc "LABEL" args in - let vlan = if List.mem_assoc "VLAN" args then Some (List.assoc "VLAN" args) else None in - Inventory.reread_inventory (); + let vlan = + if List.mem_assoc "VLAN" args then Some (List.assoc "VLAN" args) else None + in + Inventory.reread_inventory () ; let bridge_name = let inventory_bridge = try Some (Inventory.lookup Inventory._management_interface) @@ -51,84 +67,115 @@ let read_management_conf () = in match inventory_bridge with | Some "" | None -> - let bridge = - if vlan = None then - bridge_naming_convention device - else - (* At this point, we don't know what the VLAN bridge name will be, - * so use a temporary name. Xapi will replace the bridge once the name - * has been decided on. *) - temp_vlan - in - debug "No management bridge in inventory file... using %s" bridge; - bridge + let bridge = + if vlan = None then + bridge_naming_convention device + else + (* At this point, we don't know what the VLAN bridge name will be, + * so use a temporary name. Xapi will replace the bridge once the name + * has been decided on. *) + temp_vlan + in + debug "No management bridge in inventory file... using %s" bridge ; + bridge | Some bridge -> - debug "Management bridge in inventory file: %s" bridge; - bridge + debug "Management bridge in inventory file: %s" bridge ; + bridge in let mac = Network_utils.Ip.get_mac device in let ipv4_conf, ipv4_gateway, dns = match List.assoc "MODE" args with | "static" -> - let ip = List.assoc "IP" args |> Unix.inet_addr_of_string in - let prefixlen = List.assoc "NETMASK" args |> netmask_to_prefixlen in - let gateway = - if List.mem_assoc "GATEWAY" args then - Some (List.assoc "GATEWAY" args |> Unix.inet_addr_of_string) - else None - in - let nameservers = - if List.mem_assoc "DNS" args && List.assoc "DNS" args <> "" then - List.map Unix.inet_addr_of_string (Astring.String.cuts ~empty:false ~sep:"," (List.assoc "DNS" args)) - else [] - in - let domains = - if List.mem_assoc "DOMAIN" args && List.assoc "DOMAIN" args <> "" then - Astring.String.cuts ~empty:false ~sep:" " (List.assoc "DOMAIN" args) - else [] - in - let dns = nameservers, domains in - Static4 [ip, prefixlen], gateway, dns + let ip = List.assoc "IP" args |> Unix.inet_addr_of_string in + let prefixlen = List.assoc "NETMASK" args |> netmask_to_prefixlen in + let gateway = + if List.mem_assoc "GATEWAY" args then + Some (List.assoc "GATEWAY" args |> Unix.inet_addr_of_string) + else + None + in + let nameservers = + if List.mem_assoc "DNS" args && List.assoc "DNS" args <> "" then + List.map Unix.inet_addr_of_string + (Astring.String.cuts ~empty:false ~sep:"," + (List.assoc "DNS" args)) + else + [] + in + let domains = + if List.mem_assoc "DOMAIN" args && List.assoc "DOMAIN" args <> "" + then + Astring.String.cuts ~empty:false ~sep:" " + (List.assoc "DOMAIN" args) + else + [] + in + let dns = (nameservers, domains) in + (Static4 [(ip, prefixlen)], gateway, dns) | "dhcp" | _ -> - DHCP4, None, ([], []) + (DHCP4, None, ([], [])) + in + let phy_interface = {default_interface with persistent_i= true} in + let bridge_interface = + {default_interface with ipv4_conf; ipv4_gateway; persistent_i= true; dns} in - let phy_interface = {default_interface with persistent_i = true} in - let bridge_interface = {default_interface with ipv4_conf; ipv4_gateway; persistent_i = true; dns} in let interface_config, bridge_config = - let primary_bridge_conf = {default_bridge with - bridge_mac = Some mac; - ports = [device, {default_port with interfaces = [device]}]; - persistent_b = true - } in + let primary_bridge_conf = + { + default_bridge with + bridge_mac= Some mac + ; ports= [(device, {default_port with interfaces= [device]})] + ; persistent_b= true + } + in match vlan with | None -> - [device, phy_interface; bridge_name, bridge_interface], - [bridge_name, primary_bridge_conf] + ( [(device, phy_interface); (bridge_name, bridge_interface)] + , [(bridge_name, primary_bridge_conf)] ) | Some vlan -> - let parent = bridge_naming_convention device in - let secondary_bridge_conf = {default_bridge with - vlan = Some (parent, int_of_string vlan); - bridge_mac = (Some mac); - persistent_b = true - } in - let parent_bridge_interface = {default_interface with persistent_i = true} in - [device, phy_interface; parent, parent_bridge_interface; bridge_name, bridge_interface], - [parent, primary_bridge_conf; bridge_name, secondary_bridge_conf] + let parent = bridge_naming_convention device in + let secondary_bridge_conf = + { + default_bridge with + vlan= Some (parent, int_of_string vlan) + ; bridge_mac= Some mac + ; persistent_b= true + } + in + let parent_bridge_interface = + {default_interface with persistent_i= true} + in + ( [ + (device, phy_interface) + ; (parent, parent_bridge_interface) + ; (bridge_name, bridge_interface) + ] + , [ + (parent, primary_bridge_conf); (bridge_name, secondary_bridge_conf) + ] ) in - {interface_config = interface_config; bridge_config = bridge_config; - gateway_interface = Some bridge_name; dns_interface = Some bridge_name} + { + interface_config + ; bridge_config + ; gateway_interface= Some bridge_name + ; dns_interface= Some bridge_name + } with e -> error "Error while trying to read firstboot data: %s\n%s" - (Printexc.to_string e) (Printexc.get_backtrace ()); + (Printexc.to_string e) + (Printexc.get_backtrace ()) ; raise Read_error let write_config config = try - let config_json = config |> Rpcmarshal.marshal typ_of_config_t |> Jsonrpc.to_string in + let config_json = + config |> Rpcmarshal.marshal typ_of_config_t |> Jsonrpc.to_string + in Xapi_stdext_unix.Unixext.write_string_to_file config_file_path config_json with e -> error "Error while trying to write networkd configuration: %s\n%s" - (Printexc.to_string e) (Printexc.get_backtrace ()); + (Printexc.to_string e) + (Printexc.get_backtrace ()) ; raise Write_error (* Porting network interaface to ppx: convert ipv4_routes from (string * int * string) list to {gateway:string; netmask:int; subnet:string} *) @@ -138,53 +185,82 @@ let convert_configuration cfg = let convert_ipv4_route cfg = match cfg with | `List [`String gateway; `Int netmask; `String subnet] -> - debug "convert ipv4 route"; - `Assoc ["gateway", `String gateway; "netmask", `Int netmask; "subnet", `String subnet] - | other -> other + debug "convert ipv4 route" ; + `Assoc + [ + ("gateway", `String gateway) + ; ("netmask", `Int netmask) + ; ("subnet", `String subnet) + ] + | other -> + other in match cfg with | `List l -> - `List (List.map convert_ipv4_route l) - | other -> other + `List (List.map convert_ipv4_route l) + | other -> + other in let convert_interface_item cfg = match cfg with | `Assoc l -> - `Assoc (List.map (fun (k, v) -> - let v = if k = "ipv4_routes" then convert_ipv4_routes v else v in - k, v - ) l) - | other -> other + `Assoc + (List.map + (fun (k, v) -> + let v = if k = "ipv4_routes" then convert_ipv4_routes v else v in + (k, v)) + l) + | other -> + other in let convert_interface_config cfg = match cfg with | `Assoc l -> - `Assoc (List.map (fun (k, v) -> k, convert_interface_item v) l) - | other -> other + `Assoc (List.map (fun (k, v) -> (k, convert_interface_item v)) l) + | other -> + other in - let json = match from_string cfg with + let json = + match from_string cfg with | `Assoc l -> - `Assoc (List.map (fun (k, v) -> - let v = if k = "interface_config" then convert_interface_config v else v in - k, v - ) l) - | other -> other + `Assoc + (List.map + (fun (k, v) -> + let v = + if k = "interface_config" then + convert_interface_config v + else + v + in + (k, v)) + l) + | other -> + other in to_string json let read_config () = try - let config_json = Xapi_stdext_unix.Unixext.string_of_file config_file_path |> convert_configuration in - match config_json |> Jsonrpc.of_string |> Rpcmarshal.unmarshal typ_of_config_t with - | Result.Ok v -> v + let config_json = + Xapi_stdext_unix.Unixext.string_of_file config_file_path + |> convert_configuration + in + match + config_json |> Jsonrpc.of_string |> Rpcmarshal.unmarshal typ_of_config_t + with + | Result.Ok v -> + v | Result.Error (`Msg err_msg) -> - error "Read configuration error: %s" err_msg; - raise Read_error + error "Read configuration error: %s" err_msg ; + raise Read_error with | Unix.Unix_error (Unix.ENOENT, _, file) -> - info "Cannot read networkd configuration file %s because it does not exist." file; - raise Read_error + info + "Cannot read networkd configuration file %s because it does not exist." + file ; + raise Read_error | e -> - info "Error while trying to read networkd configuration: %s\n%s" - (Printexc.to_string e) (Printexc.get_backtrace ()); - raise Read_error + info "Error while trying to read networkd configuration: %s\n%s" + (Printexc.to_string e) + (Printexc.get_backtrace ()) ; + raise Read_error diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 9b275ad59..11e7cadb9 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -16,7 +16,8 @@ open Xapi_stdext_pervasives open Xapi_stdext_unix open Network_interface -module D = Debug.Make(struct let name = "network_utils" end) +module D = Debug.Make (struct let name = "network_utils" end) + open D type util_error = @@ -37,70 +38,105 @@ type util_error = | Other let iproute2 = "/sbin/ip" + let resolv_conf = "/etc/resolv.conf" + let dhclient = "/sbin/dhclient" + let sysctl = "/sbin/sysctl" + let ovs_vsctl = "/usr/bin/ovs-vsctl" + let ovs_ofctl = "/usr/bin/ovs-ofctl" + let ovs_appctl = "/usr/bin/ovs-appctl" + let ovs_vlan_bug_workaround = "/usr/sbin/ovs-vlan-bug-workaround" + let brctl = ref "/sbin/brctl" + let modprobe = "/sbin/modprobe" + let ethtool = ref "/sbin/ethtool" + let bonding_dir = "/proc/net/bonding/" + let uname = ref "/usr/bin/uname" + let dracut = ref "/sbin/dracut" + let modinfo = ref "/sbin/modinfo" + let dracut_timeout = ref 180.0 + let fcoedriver = ref "/opt/xensource/libexec/fcoe_driver" + let inject_igmp_query_script = ref "/usr/libexec/xenopsd/igmp_query_injector.py" + let mac_table_size = ref 10000 + let igmp_query_maxresp_time = ref "5000" + let enable_ipv6_mcast_snooping = ref false + let mcast_snooping_disable_flood_unregistered = ref true let default_error_handler script args stdout stderr status = let message = match status with - | Unix.WEXITED n -> Printf.sprintf "Exit code %d" n - | Unix.WSIGNALED s -> Printf.sprintf "Signaled %d" s (* Note that this is the internal ocaml signal number, see Sys module *) - | Unix.WSTOPPED s -> Printf.sprintf "Stopped %d" s + | Unix.WEXITED n -> + Printf.sprintf "Exit code %d" n + | Unix.WSIGNALED s -> + Printf.sprintf "Signaled %d" s + (* Note that this is the internal ocaml signal number, see Sys module *) + | Unix.WSTOPPED s -> + Printf.sprintf "Stopped %d" s in error "Call '%s %s' exited badly: %s [stdout = '%s'; stderr = '%s']" script - (String.concat " " args) message stdout stderr; - raise (Network_error (Script_error ["script", script; - "args", String.concat " " args; - "code", message; - "stdout", stdout; - "stderr", stderr])) - -let check_n_run ?(on_error=default_error_handler) ?(log=true) run_func script args = + (String.concat " " args) message stdout stderr ; + raise + (Network_error + (Script_error + [ + ("script", script) + ; ("args", String.concat " " args) + ; ("code", message) + ; ("stdout", stdout) + ; ("stderr", stderr) + ])) + +let check_n_run ?(on_error = default_error_handler) ?(log = true) run_func + script args = try - Unix.access script [ Unix.X_OK ]; + Unix.access script [Unix.X_OK] ; (* Use the same $PATH as xapi *) - let env = [| "PATH=" ^ (Sys.getenv "PATH") |] in + let env = [|"PATH=" ^ Sys.getenv "PATH"|] in if log then - info "%s %s" script (String.concat " " args); + info "%s %s" script (String.concat " " args) ; run_func env script args with | Unix.Unix_error (e, a, b) -> - error "Caught unix error: %s [%s, %s]" (Unix.error_message e) a b; - error "Assuming script %s doesn't exist" script; - raise (Network_error (Script_missing script)) - | Forkhelpers.Spawn_internal_error(stderr, stdout, status)-> - on_error script args stdout stderr status + error "Caught unix error: %s [%s, %s]" (Unix.error_message e) a b ; + error "Assuming script %s doesn't exist" script ; + raise (Network_error (Script_missing script)) + | Forkhelpers.Spawn_internal_error (stderr, stdout, status) -> + on_error script args stdout stderr status -let call_script ?(timeout=Some 60.0) ?on_error ?log script args = +let call_script ?(timeout = Some 60.0) ?on_error ?log script args = let call_script_internal env script args = - let (out,_err) = Forkhelpers.execute_command_get_output ~env ?timeout script args in + let out, _err = + Forkhelpers.execute_command_get_output ~env ?timeout script args + in out in check_n_run ?on_error ?log call_script_internal script args let fork_script ?on_error ?log script args = let fork_script_internal env script args = - let pid = Forkhelpers.safe_close_and_exec ~env None None None [] script args in - Forkhelpers.dontwaitpid pid; + let pid = + Forkhelpers.safe_close_and_exec ~env None None None [] script args + in + Forkhelpers.dontwaitpid pid in check_n_run ?on_error ?log fork_script_internal script args @@ -109,52 +145,53 @@ module Sysfs = struct let all = Array.to_list (Sys.readdir "/sys/class/net") in List.filter (fun name -> Sys.is_directory ("/sys/class/net/" ^ name)) all - let exists dev = - List.mem dev @@ list () + let exists dev = List.mem dev @@ list () let assert_exists dev = if not @@ exists dev then raise (Network_error (Interface_does_not_exist dev)) let list_drivers () = - try - Array.to_list (Sys.readdir "/sys/bus/pci/drivers") + try Array.to_list (Sys.readdir "/sys/bus/pci/drivers") with _ -> - warn "Failed to obtain list of drivers from sysfs"; + warn "Failed to obtain list of drivers from sysfs" ; [] - let getpath dev attr = - Printf.sprintf "/sys/class/net/%s/%s" dev attr + let getpath dev attr = Printf.sprintf "/sys/class/net/%s/%s" dev attr let read_one_line file = try - Unixext.string_of_file file - |> String.split_on_char '\n' - |> List.hd + Unixext.string_of_file file |> String.split_on_char '\n' |> List.hd (* Note: the list returned by split_on_char is guaranteed to be non-empty *) with - | End_of_file -> "" + | End_of_file -> + "" | Unix.Unix_error (Unix.EINVAL, _, _) -> - (* The device is not yet up *) - raise (Network_error (Read_error file)) + (* The device is not yet up *) + raise (Network_error (Read_error file)) | exn -> - error "Error in read one line of file: %s, exception %s\n%s" - file (Printexc.to_string exn) (Printexc.get_backtrace ()); - raise (Network_error (Read_error file)) + error "Error in read one line of file: %s, exception %s\n%s" file + (Printexc.to_string exn) + (Printexc.get_backtrace ()) ; + raise (Network_error (Read_error file)) let write_one_line file l = let outchan = open_out file in try - output_string outchan (l ^ "\n"); + output_string outchan (l ^ "\n") ; close_out outchan - with _ -> close_out outchan; raise (Network_error (Write_error file)) + with _ -> + close_out outchan ; + raise (Network_error (Write_error file)) let is_physical name = try let devpath = getpath name "device" in let driver_link = Unix.readlink (devpath ^ "/driver") in (* filter out symlinks under device/driver which look like /../../../devices/xen-backend/vif- *) - not(List.mem "xen-backend" (Astring.String.cuts ~empty:false ~sep:"/" driver_link)) + not + (List.mem "xen-backend" + (Astring.String.cuts ~empty:false ~sep:"/" driver_link)) with _ -> false let get_carrier name = @@ -177,55 +214,61 @@ module Sysfs = struct String.sub l 2 (String.length l - 2) with _ -> "" in - read_id_from (getpath name "device/vendor"), - read_id_from (getpath name "device/device") + ( read_id_from (getpath name "device/vendor") + , read_id_from (getpath name "device/device") ) (** Returns the name of the driver for network device [dev] *) let get_driver_name dev = try let driver_path = Unix.readlink (getpath dev "device/driver") in match Astring.String.cut ~sep:"/" ~rev:true driver_path with - | Some (_prefix, suffix) -> Some suffix + | Some (_prefix, suffix) -> + Some suffix | None -> - debug "get %s driver name: %s does not contain slash" dev driver_path; - None + debug "get %s driver name: %s does not contain slash" dev driver_path ; + None with _ -> - debug "%s: could not read netdev's driver name" dev; + debug "%s: could not read netdev's driver name" dev ; None let get_driver_name_err dev = match get_driver_name dev with - | Some a -> Result.Ok a - | None -> Result.Error (Fail_to_get_driver_name, "Failed to get driver name for: "^ dev) + | Some a -> + Result.Ok a + | None -> + Result.Error + (Fail_to_get_driver_name, "Failed to get driver name for: " ^ dev) (** Returns the features bitmap for the driver for [dev]. * The features bitmap is a set of NETIF_F_ flags supported by its driver. *) let get_features dev = - try - Some (int_of_string (read_one_line (getpath dev "features"))) - with _ -> - None + try Some (int_of_string (read_one_line (getpath dev "features"))) + with _ -> None (** Returns [true] if [dev] supports VLAN acceleration, [false] otherwise. *) let has_vlan_accel dev = let flag_NETIF_F_HW_VLAN_TX = 128 in let flag_NETIF_F_HW_VLAN_RX = 256 in - let flag_NETIF_F_VLAN = flag_NETIF_F_HW_VLAN_TX lor flag_NETIF_F_HW_VLAN_RX in + let flag_NETIF_F_VLAN = + flag_NETIF_F_HW_VLAN_TX lor flag_NETIF_F_HW_VLAN_RX + in match get_features dev with - | None -> false - | Some features -> (features land flag_NETIF_F_VLAN) <> 0 + | None -> + false + | Some features -> + features land flag_NETIF_F_VLAN <> 0 let set_multicast_snooping bridge value = try let path = getpath bridge "bridge/multicast_snooping" in write_one_line path (if value then "1" else "0") with _ -> - warn "Could not %s IGMP-snooping on bridge %s" (if value then "enable" else "disable") bridge + warn "Could not %s IGMP-snooping on bridge %s" + (if value then "enable" else "disable") + bridge let bridge_to_interfaces bridge = - try - Array.to_list (Sys.readdir (getpath bridge "brif")) - with _ -> [] + try Array.to_list (Sys.readdir (getpath bridge "brif")) with _ -> [] let get_all_bridges () = let ifaces = list () in @@ -235,80 +278,101 @@ module Sysfs = struct * The units of speed are specified in pif_record in xen-api/xapi/records.ml. * Note: these data are present in sysfs from kernel 2.6.33. *) let get_status name = - let speed = getpath name "speed" - |> (fun p -> try (read_one_line p |> int_of_string) with _ -> 0) + let speed = + getpath name "speed" |> fun p -> + try read_one_line p |> int_of_string with _ -> 0 + in + let duplex = + getpath name "duplex" |> fun p -> + try read_one_line p |> duplex_of_string with _ -> Duplex_unknown in - let duplex = getpath name "duplex" - |> (fun p -> try read_one_line p |> duplex_of_string with _ -> Duplex_unknown) - in (speed, duplex) + (speed, duplex) let get_dev_nums_with_same_driver driver = try Sys.readdir ("/sys/bus/pci/drivers/" ^ driver) |> Array.to_list - |> List.filter (Re.execp (Re.Perl.compile_pat {|\d+:[a-f\d]+:[a-f\d]+\.\d|})) + |> List.filter + (Re.execp (Re.Perl.compile_pat {|\d+:[a-f\d]+:[a-f\d]+\.\d|})) |> List.length with _ -> 0 let parent_device_of_vf pcibuspath = try - let pf_net_path = Printf.sprintf "/sys/bus/pci/devices/%s/physfn/net" pcibuspath in + let pf_net_path = + Printf.sprintf "/sys/bus/pci/devices/%s/physfn/net" pcibuspath + in let devices = Sys.readdir pf_net_path in Result.Ok devices.(0) - with _ -> Result.Error (Parent_device_of_vf_not_found, "Can not get parent device for " ^ pcibuspath) + with _ -> + Result.Error + ( Parent_device_of_vf_not_found + , "Can not get parent device for " ^ pcibuspath ) let get_child_vfs_sysfs_paths dev = try let device_path = getpath dev "device" in - Result. Ok ( - Sys.readdir device_path + Result.Ok + (Sys.readdir device_path |> Array.to_list - |> List.filter (Re.execp (Re.Perl.compile_pat "virtfn(\\d+)")) (* List elements are like "virtfn1" *) + |> List.filter (Re.execp (Re.Perl.compile_pat "virtfn(\\d+)")) + (* List elements are like "virtfn1" *) |> List.map (Filename.concat device_path) - ) - with _ -> Result.Error (Vf_sysfs_path_not_found, "Can not get child vfs sysfs paths for " ^ dev) + ) + with _ -> + Result.Error + (Vf_sysfs_path_not_found, "Can not get child vfs sysfs paths for " ^ dev) let device_index_of_vf parent_dev pcibuspath = try let open Rresult.R.Infix in get_child_vfs_sysfs_paths parent_dev >>= fun paths -> let group = - List.find (fun x -> Astring.String.is_infix ~affix:pcibuspath (Unix.readlink x)) paths + List.find + (fun x -> Astring.String.is_infix ~affix:pcibuspath (Unix.readlink x)) + paths |> Re.exec_opt (Re.Perl.compile_pat "virtfn(\\d+)") in match group with - | None -> Result.Error (Vf_index_not_found, "Can not get device index for " ^ pcibuspath) - | Some x -> Ok (int_of_string (Re.Group.get x 1)) - with _ -> Result.Error (Vf_index_not_found, "Can not get device index for " ^ pcibuspath) + | None -> + Result.Error + (Vf_index_not_found, "Can not get device index for " ^ pcibuspath) + | Some x -> + Ok (int_of_string (Re.Group.get x 1)) + with _ -> + Result.Error + (Vf_index_not_found, "Can not get device index for " ^ pcibuspath) let unbind_child_vfs dev = let open Rresult.R.Infix in let unbind vf_path = let driver_name = try - Unix.readlink (Filename.concat vf_path "driver") - |> Filename.basename + Unix.readlink (Filename.concat vf_path "driver") |> Filename.basename with _ -> "" - and vf_pcibuspath = - Unix.readlink vf_path - |> Filename.basename - in - if driver_name = "" then Result.Ok () (* not bind to any driver, Ok *) - else begin - debug "unbinding %s from driver %s at %s" vf_path driver_name vf_pcibuspath; + and vf_pcibuspath = Unix.readlink vf_path |> Filename.basename in + if driver_name = "" then + Result.Ok () (* not bind to any driver, Ok *) + else ( + debug "unbinding %s from driver %s at %s" vf_path driver_name + vf_pcibuspath ; let unbind_interface = Filename.concat vf_path "driver/unbind" - and remove_slot_interface = Filename.concat vf_path "driver/remove_slot" in - begin try - write_one_line remove_slot_interface vf_pcibuspath - with _ -> () - end; + and remove_slot_interface = + Filename.concat vf_path "driver/remove_slot" + in + (try write_one_line remove_slot_interface vf_pcibuspath with _ -> ()) ; try - write_one_line unbind_interface vf_pcibuspath; Result.Ok () - with _ -> Result.Error (Fail_to_unbind_from_driver, Printf.sprintf "%s: VF Fail to be unbound from driver %s" vf_path driver_name) - end + write_one_line unbind_interface vf_pcibuspath ; + Result.Ok () + with _ -> + Result.Error + ( Fail_to_unbind_from_driver + , Printf.sprintf "%s: VF Fail to be unbound from driver %s" vf_path + driver_name ) + ) in get_child_vfs_sysfs_paths dev >>= fun paths -> - List.fold_left (>>=) (Ok ()) (List.map (fun x -> fun _ -> unbind x) paths) + List.fold_left ( >>= ) (Ok ()) (List.map (fun x _ -> unbind x) paths) let get_sriov_numvfs dev = try @@ -320,59 +384,71 @@ module Sysfs = struct let get_sriov_maxvfs dev = try - Ok (getpath dev "device/sriov_totalvfs" - |> read_one_line - |> String.trim - |> int_of_string) - with _ -> Error (Fail_to_get_maxvfs, "Failed to get maxvfs from sysfs interface for device: " ^ dev) + Ok + (getpath dev "device/sriov_totalvfs" + |> read_one_line + |> String.trim + |> int_of_string + ) + with _ -> + Error + ( Fail_to_get_maxvfs + , "Failed to get maxvfs from sysfs interface for device: " ^ dev ) let set_sriov_numvfs dev num_vfs = let interface = getpath dev "device/sriov_numvfs" in try - write_one_line interface (string_of_int num_vfs); - if get_sriov_numvfs dev = num_vfs then Result.Ok () - else Result.Error (Other, "Error: set SR-IOV error on " ^ dev) + write_one_line interface (string_of_int num_vfs) ; + if get_sriov_numvfs dev = num_vfs then + Result.Ok () + else + Result.Error (Other, "Error: set SR-IOV error on " ^ dev) with | Sys_error s when Astring.String.is_infix ~affix:"out of range of" s -> - Result.Error (Bus_out_of_range, "Error: bus out of range when setting SR-IOV numvfs on " ^ dev) - | Sys_error s when Astring.String.is_infix ~affix:"not enough MMIO resources" s -> - Result.Error (Not_enough_mmio_resources, "Error: not enough mmio resources when setting SR-IOV numvfs on " ^ dev) + Result.Error + ( Bus_out_of_range + , "Error: bus out of range when setting SR-IOV numvfs on " ^ dev ) + | Sys_error s + when Astring.String.is_infix ~affix:"not enough MMIO resources" s -> + Result.Error + ( Not_enough_mmio_resources + , "Error: not enough mmio resources when setting SR-IOV numvfs on " + ^ dev ) | e -> - let msg = Printf.sprintf "Error: set SR-IOV numvfs error with exception %s on %s" (Printexc.to_string e) dev in - Result.Error (Other, msg) + let msg = + Printf.sprintf + "Error: set SR-IOV numvfs error with exception %s on %s" + (Printexc.to_string e) dev + in + Result.Error (Other, msg) end module Ip = struct type ipversion = V4 | V6 | V46 - let string_of_version = function - | V4 -> ["-4"] - | V6 -> ["-6"] - | V46 -> [] + let string_of_version = function V4 -> ["-4"] | V6 -> ["-6"] | V46 -> [] - let call ?log args = - call_script ?log iproute2 args + let call ?log args = call_script ?log iproute2 args let find output attr = let args = Astring.String.fields ~empty:false output in - let indices = (Xapi_stdext_std.Listext.List.position (fun s -> s = attr) args) in + let indices = + Xapi_stdext_std.Listext.List.position (fun s -> s = attr) args + in List.map (fun i -> List.nth args (succ i)) indices let get_link_flags dev = - Sysfs.assert_exists dev; + Sysfs.assert_exists dev ; let output = call ~log:false ["link"; "show"; "dev"; dev] in let i = String.index output '<' in let j = String.index output '>' in let flags = String.sub output (i + 1) (j - i - 1) in Astring.String.cuts ~empty:false ~sep:"," flags - let is_up dev = - try - List.mem "UP" (get_link_flags dev) - with _ -> false + let is_up dev = try List.mem "UP" (get_link_flags dev) with _ -> false let link_set dev args = - Sysfs.assert_exists dev; + Sysfs.assert_exists dev ; ignore (call ("link" :: "set" :: dev :: args)) let link_set_mtu dev mtu = @@ -380,8 +456,7 @@ module Ip = struct with Network_error (Script_error _) -> error "MTU size is not supported: %d" mtu - let link_set_up dev = - link_set dev ["up"] + let link_set_up dev = link_set dev ["up"] let link_set_down dev = if is_up dev then @@ -389,75 +464,75 @@ module Ip = struct let with_links_down devs f = let up_links = List.filter (fun dev -> is_up dev) devs in - List.iter (fun dev -> link_set dev ["down"]) up_links; - Pervasiveext.finally - f - (fun () -> List.iter link_set_up up_links) + List.iter (fun dev -> link_set dev ["down"]) up_links ; + Pervasiveext.finally f (fun () -> List.iter link_set_up up_links) - let link ?(version=V46) dev attr = - Sysfs.assert_exists dev; + let link ?(version = V46) dev attr = + Sysfs.assert_exists dev ; let v = string_of_version version in let output = call ~log:false (v @ ["link"; "show"; "dev"; dev]) in find output attr - let addr ?(version=V46) dev attr = - Sysfs.assert_exists dev; + let addr ?(version = V46) dev attr = + Sysfs.assert_exists dev ; let v = string_of_version version in let output = call ~log:false (v @ ["addr"; "show"; "dev"; dev]) in find output attr - let get_mtu dev = - int_of_string (List.hd (link dev "mtu")) + let get_mtu dev = int_of_string (List.hd (link dev "mtu")) - let get_mac dev = - List.hd (link dev "link/ether") + let get_mac dev = List.hd (link dev "link/ether") let set_mac dev mac = - try - ignore (link_set dev ["address"; mac]) - with _ -> () + try ignore (link_set dev ["address"; mac]) with _ -> () let split_addr addr = match Astring.String.cut ~sep:"/" addr with | Some (ipstr, prefixlenstr) -> - let ip = Unix.inet_addr_of_string ipstr in - let prefixlen = int_of_string prefixlenstr in - Some (ip, prefixlen) - | None -> None + let ip = Unix.inet_addr_of_string ipstr in + let prefixlen = int_of_string prefixlenstr in + Some (ip, prefixlen) + | None -> + None (* see http://en.wikipedia.org/wiki/IPv6_address#Modified_EUI-64 *) let get_ipv6_interface_id dev = let mac = get_mac dev in - let bytes = List.map (fun byte -> int_of_string ("0x" ^ byte)) (Astring.String.cuts ~empty:false ~sep:":" mac) in + let bytes = + List.map + (fun byte -> int_of_string ("0x" ^ byte)) + (Astring.String.cuts ~empty:false ~sep:":" mac) + in let rec modified_bytes ac i = function | [] -> - ac + ac | head :: tail -> - if i = 0 then - let head' = head lxor 2 in - modified_bytes (head' :: ac) 1 tail - else if i = 2 then - modified_bytes (254 :: 255 :: head :: ac) 3 tail - else - modified_bytes (head :: ac) (i + 1) tail + if i = 0 then + let head' = head lxor 2 in + modified_bytes (head' :: ac) 1 tail + else if i = 2 then + modified_bytes (254 :: 255 :: head :: ac) 3 tail + else + modified_bytes (head :: ac) (i + 1) tail in let bytes' = List.rev (modified_bytes [] 0 bytes) in [0; 0; 0; 0; 0; 0; 0; 0] @ bytes' let get_ipv6_link_local_addr dev = let id = get_ipv6_interface_id dev in - let link_local = 0xfe :: 0x80 :: (List.tl (List.tl id)) in + let link_local = 0xfe :: 0x80 :: List.tl (List.tl id) in let rec to_string ac i = function - | [] -> ac + | [] -> + ac | hd :: tl -> - let separator = - if i = 0 || i mod 2 = 1 then - "" - else - ":" - in - let ac' = ac ^ separator ^ Printf.sprintf "%02x" hd in - to_string ac' (i + 1) tl + let separator = + if i = 0 || i mod 2 = 1 then + "" + else + ":" + in + let ac' = ac ^ separator ^ Printf.sprintf "%02x" hd in + to_string ac' (i + 1) tl in to_string "" 0 link_local ^ "/64" @@ -475,21 +550,20 @@ module Ip = struct (* Set the broadcast address when adding an IPv4 address *) if String.contains addr '.' then ["broadcast"; "+"] - else [] + else + [] in - try - ignore (call (["addr"; "add"; addr; "dev"; dev] @ broadcast)) + try ignore (call (["addr"; "add"; addr; "dev"; dev] @ broadcast)) with _ -> () let set_ipv6_link_local_addr dev = let addr = get_ipv6_link_local_addr dev in - try - ignore (call ["addr"; "add"; addr; "dev"; dev; "scope"; "link"]) + try ignore (call ["addr"; "add"; addr; "dev"; dev; "scope"; "link"]) with _ -> () - let flush_ip_addr ?(ipv6=false) dev = + let flush_ip_addr ?(ipv6 = false) dev = try - Sysfs.assert_exists dev; + Sysfs.assert_exists dev ; let mode = if ipv6 then "-6" else "-4" in ignore (call [mode; "addr"; "flush"; "dev"; dev]) with _ -> () @@ -497,34 +571,67 @@ module Ip = struct let del_ip_addr dev (ip, prefixlen) = let addr = Printf.sprintf "%s/%d" (Unix.string_of_inet_addr ip) prefixlen in try - Sysfs.assert_exists dev; + Sysfs.assert_exists dev ; ignore (call ["addr"; "del"; addr; "dev"; dev]) with _ -> () - let route_show ?(version=V46) dev = + let route_show ?(version = V46) dev = let v = string_of_version version in call ~log:false (v @ ["route"; "show"; "dev"; dev]) let set_route ?network dev gateway = try - Sysfs.assert_exists dev; + Sysfs.assert_exists dev ; match network with | None -> - ignore (call ["route"; "replace"; "default"; "via"; Unix.string_of_inet_addr gateway; "dev"; dev]) + ignore + (call + [ + "route" + ; "replace" + ; "default" + ; "via" + ; Unix.string_of_inet_addr gateway + ; "dev" + ; dev + ]) | Some (ip, prefixlen) -> - let addr = Printf.sprintf "%s/%d" (Unix.string_of_inet_addr ip) prefixlen in - ignore (call ["route"; "replace"; addr; "via"; Unix.string_of_inet_addr gateway; "dev"; dev]) + let addr = + Printf.sprintf "%s/%d" (Unix.string_of_inet_addr ip) prefixlen + in + ignore + (call + [ + "route" + ; "replace" + ; addr + ; "via" + ; Unix.string_of_inet_addr gateway + ; "dev" + ; dev + ]) with _ -> () let set_gateway dev gateway = set_route dev gateway - let vlan_name interface vlan = - Printf.sprintf "%s.%d" interface vlan + let vlan_name interface vlan = Printf.sprintf "%s.%d" interface vlan let create_vlan interface vlan = if not (Sysfs.exists (vlan_name interface vlan)) then - ignore (call ["link"; "add"; "link"; interface; "name"; vlan_name interface vlan; - "type"; "vlan"; "id"; string_of_int vlan]) + ignore + (call + [ + "link" + ; "add" + ; "link" + ; interface + ; "name" + ; vlan_name interface vlan + ; "type" + ; "vlan" + ; "id" + ; string_of_int vlan + ]) let destroy_vlan name = if Sysfs.exists name then @@ -532,79 +639,83 @@ module Ip = struct let set_vf_mac dev index mac = try - debug "Setting VF MAC address for dev: %s, index: %d, MAC: %s" dev index mac; + debug "Setting VF MAC address for dev: %s, index: %d, MAC: %s" dev index + mac ; Result.Ok (link_set dev ["vf"; string_of_int index; "mac"; mac]) - with _ -> Result.Error (Fail_to_set_vf_mac, "Failed to set VF MAC for: " ^ dev) + with _ -> + Result.Error (Fail_to_set_vf_mac, "Failed to set VF MAC for: " ^ dev) let set_vf_vlan dev index vlan = try - debug "Setting VF VLAN for dev: %s, index: %d, VLAN: %d" dev index vlan; - Result.Ok (link_set dev ["vf"; string_of_int index; "vlan"; string_of_int vlan]) - with _ -> Result.Error (Fail_to_set_vf_vlan, "Failed to set VF VLAN for: " ^ dev) + debug "Setting VF VLAN for dev: %s, index: %d, VLAN: %d" dev index vlan ; + Result.Ok + (link_set dev ["vf"; string_of_int index; "vlan"; string_of_int vlan]) + with _ -> + Result.Error (Fail_to_set_vf_vlan, "Failed to set VF VLAN for: " ^ dev) (* We know some NICs do not support config VF Rate, so will explicitly tell XAPI this error*) let set_vf_rate dev index rate = try - debug "Setting VF rate for dev: %s, index: %d, rate: %d" dev index rate; - Result.Ok (link_set dev ["vf"; string_of_int index; "rate"; string_of_int rate]) - with _ -> Result.Error (Fail_to_set_vf_rate, "Failed to set VF rate for: " ^ dev) + debug "Setting VF rate for dev: %s, index: %d, rate: %d" dev index rate ; + Result.Ok + (link_set dev ["vf"; string_of_int index; "rate"; string_of_int rate]) + with _ -> + Result.Error (Fail_to_set_vf_rate, "Failed to set VF rate for: " ^ dev) end module Linux_bonding = struct let bonding_masters = "/sys/class/net/bonding_masters" let load_bonding_driver () = - debug "Loading bonding driver"; + debug "Loading bonding driver" ; try - ignore (call_script modprobe ["bonding"]); + ignore (call_script modprobe ["bonding"]) ; (* is_bond_device() uses the contents of sysfs_bonding_masters to work out which devices * have already been created. Unfortunately the driver creates "bond0" automatically at * modprobe init. Get rid of this now or our accounting will go wrong. *) Sysfs.write_one_line bonding_masters "-bond0" - with _ -> - error "Failed to load bonding driver" + with _ -> error "Failed to load bonding driver" let bonding_driver_loaded () = try - Unix.access bonding_masters [Unix.F_OK]; + Unix.access bonding_masters [Unix.F_OK] ; true - with _ -> - false + with _ -> false let is_bond_device name = try - List.exists ((=) name) (Astring.String.cuts ~empty:false ~sep:" " (Sysfs.read_one_line bonding_masters)) + List.exists (( = ) name) + (Astring.String.cuts ~empty:false ~sep:" " + (Sysfs.read_one_line bonding_masters)) with _ -> false (** Ensures that a bond master device exists in the kernel. *) let add_bond_master name = if not (bonding_driver_loaded ()) then - load_bonding_driver (); + load_bonding_driver () ; if is_bond_device name then debug "Bond master %s already exists, not creating" name - else begin - debug "Adding bond master %s" name; - try - Sysfs.write_one_line bonding_masters ("+" ^ name) - with _ -> - error "Failed to add bond master %s" name - end + else ( + debug "Adding bond master %s" name ; + try Sysfs.write_one_line bonding_masters ("+" ^ name) + with _ -> error "Failed to add bond master %s" name + ) (** No, Mr. Bond, I expect you to die. *) let remove_bond_master name = - if is_bond_device name then begin + if is_bond_device name then let rec destroy retries = - debug "Removing bond master %s (%d attempts remain)" name retries; - try - Sysfs.write_one_line bonding_masters ("-" ^ name) + debug "Removing bond master %s (%d attempts remain)" name retries ; + try Sysfs.write_one_line bonding_masters ("-" ^ name) with _ -> - if retries > 0 then - (Thread.delay 0.5; destroy (retries - 1)) - else + if retries > 0 then ( + Thread.delay 0.5 ; + destroy (retries - 1) + ) else error "Failed to remove bond master %s" name in destroy 10 - end else + else error "Bond master %s does not exist; cannot destroy it" name let get_bond_slaves master = @@ -616,32 +727,39 @@ module Linux_bonding = struct Astring.String.cuts ~empty:false ~sep:" " slaves let add_bond_slaves master slaves = - List.iter (fun slave -> - debug "Adding slave %s to bond %s" slave master; + List.iter + (fun slave -> + debug "Adding slave %s to bond %s" slave master ; try - Sysfs.write_one_line (Sysfs.getpath master "bonding/slaves") ("+" ^ slave) - with _ -> - error "Failed to add slave %s to bond %s" slave master - ) slaves + Sysfs.write_one_line + (Sysfs.getpath master "bonding/slaves") + ("+" ^ slave) + with _ -> error "Failed to add slave %s to bond %s" slave master) + slaves let remove_bond_slaves master slaves = - List.iter (fun slave -> - debug "Removing slave %s from bond %s" slave master; + List.iter + (fun slave -> + debug "Removing slave %s from bond %s" slave master ; try - Sysfs.write_one_line (Sysfs.getpath master "bonding/slaves") ("-" ^ slave) - with _ -> - error "Failed to remove slave %s from bond %s" slave master - ) slaves + Sysfs.write_one_line + (Sysfs.getpath master "bonding/slaves") + ("-" ^ slave) + with _ -> error "Failed to remove slave %s from bond %s" slave master) + slaves let set_bond_slaves master slaves = if is_bond_device master then let current_slaves = get_bond_slaves master in - let slaves_to_remove = Xapi_stdext_std.Listext.List.set_difference current_slaves slaves in - let slaves_to_add = Xapi_stdext_std.Listext.List.set_difference slaves current_slaves in + let slaves_to_remove = + Xapi_stdext_std.Listext.List.set_difference current_slaves slaves + in + let slaves_to_add = + Xapi_stdext_std.Listext.List.set_difference slaves current_slaves + in Ip.with_links_down (slaves_to_add @ slaves_to_remove) (fun () -> - remove_bond_slaves master slaves_to_remove; - add_bond_slaves master slaves_to_add - ) + remove_bond_slaves master slaves_to_remove ; + add_bond_slaves master slaves_to_add) else error "Bond %s does not exist; cannot set slaves" master @@ -650,13 +768,9 @@ module Linux_bonding = struct try let slaves = get_bond_slaves master in Ip.with_links_down slaves (fun () -> - remove_bond_slaves master slaves; - Pervasiveext.finally - f - (fun () -> add_bond_slaves master slaves) - ) - with _ -> - error "Failed to remove or re-add slaves from bond %s" master + remove_bond_slaves master slaves ; + Pervasiveext.finally f (fun () -> add_bond_slaves master slaves)) + with _ -> error "Failed to remove or re-add slaves from bond %s" master else error "Bond %s does not exist; cannot remove/add slaves" master @@ -665,180 +779,231 @@ module Linux_bonding = struct let master_symlink = Sysfs.getpath slave "master" in let master_path = Unix.readlink master_symlink in let slaves_path = Filename.concat master_symlink "bonding/slaves" in - Unix.access slaves_path [ Unix.F_OK ]; - Some (List.hd (List.rev (Astring.String.cuts ~empty:false ~sep:"/" master_path))) + Unix.access slaves_path [Unix.F_OK] ; + Some + (List.hd + (List.rev (Astring.String.cuts ~empty:false ~sep:"/" master_path))) with _ -> None let get_bond_active_slave master = - try - Some (Sysfs.read_one_line (Sysfs.getpath master ("bonding/active_slave"))) + try Some (Sysfs.read_one_line (Sysfs.getpath master "bonding/active_slave")) with _ -> - error "Failed to get active_slave of bond %s" master; + error "Failed to get active_slave of bond %s" master ; None let known_props = ["mode"; "updelay"; "downdelay"; "miimon"; "use_carrier"] let get_bond_properties master = - if is_bond_device master then begin + if is_bond_device master then let get_prop prop = try - let bond_prop = Sysfs.read_one_line (Sysfs.getpath master ("bonding/" ^ prop)) in + let bond_prop = + Sysfs.read_one_line (Sysfs.getpath master ("bonding/" ^ prop)) + in if prop = "mode" then - Some (prop, List.hd (Astring.String.cuts ~empty:false ~sep:" " bond_prop)) - else Some (prop, bond_prop) + Some + ( prop + , List.hd (Astring.String.cuts ~empty:false ~sep:" " bond_prop) ) + else + Some (prop, bond_prop) with _ -> - debug "Failed to get property \"%s\" on bond %s" prop master; + debug "Failed to get property \"%s\" on bond %s" prop master ; None in Xapi_stdext_std.Listext.List.filter_map get_prop known_props - end else begin - debug "Bond %s does not exist; cannot get properties" master; + else ( + debug "Bond %s does not exist; cannot get properties" master ; [] - end + ) let set_bond_properties master properties = - if is_bond_device master then begin + if is_bond_device master then ( let current_props = get_bond_properties master in - debug "Current bond properties: %s" (String.concat ", " (List.map (fun (k, v) -> k ^ "=" ^ v) current_props)); + debug "Current bond properties: %s" + (String.concat ", " + (List.map (fun (k, v) -> k ^ "=" ^ v) current_props)) ; (* Find out which properties are known, but different from the current state, * and only continue if there is at least one of those. *) - let props_to_update = List.filter (fun (prop, value) -> - not (List.mem (prop, value) current_props) && List.mem prop known_props) properties in - debug "Bond properties to update: %s" (String.concat ", " (List.map (fun (k, v) -> k ^ "=" ^ v) props_to_update)); + let props_to_update = + List.filter + (fun (prop, value) -> + (not (List.mem (prop, value) current_props)) + && List.mem prop known_props) + properties + in + debug "Bond properties to update: %s" + (String.concat ", " + (List.map (fun (k, v) -> k ^ "=" ^ v) props_to_update)) ; if props_to_update <> [] then let set_prop (prop, value) = try - debug "Setting %s=%s on bond %s" prop value master; - Sysfs.write_one_line (Sysfs.getpath master ("bonding/" ^ prop)) value + debug "Setting %s=%s on bond %s" prop value master ; + Sysfs.write_one_line + (Sysfs.getpath master ("bonding/" ^ prop)) + value with _ -> error "Failed to set property \"%s\" on bond %s" prop master in Ip.with_links_down [master] (fun () -> with_slaves_removed master (fun () -> - List.iter set_prop props_to_update - ) - ) - end else + List.iter set_prop props_to_update)) + ) else error "Bond %s does not exist; cannot set properties" master end -module Dhclient : -sig +module Dhclient : sig type interface = string + val remove_conf_file : ?ipv6:bool -> interface -> unit + val is_running : ?ipv6:bool -> interface -> bool + val stop : ?ipv6:bool -> interface -> unit - val ensure_running : ?ipv6:bool -> interface -> [> `dns of string | `gateway of string ] list -> unit -end = -struct + + val ensure_running : + ?ipv6:bool + -> interface + -> [> `dns of string | `gateway of string] list + -> unit +end = struct type interface = string - let pid_file ?(ipv6=false) interface = + let pid_file ?(ipv6 = false) interface = let ipv6' = if ipv6 then "6" else "" in Printf.sprintf "/var/run/dhclient%s-%s.pid" ipv6' interface - let lease_file ?(ipv6=false) interface = + let lease_file ?(ipv6 = false) interface = let ipv6' = if ipv6 then "6" else "" in - Filename.concat "/var/lib/xcp" (Printf.sprintf "dhclient%s-%s.leases" ipv6' interface) + Filename.concat "/var/lib/xcp" + (Printf.sprintf "dhclient%s-%s.leases" ipv6' interface) - let conf_file ?(ipv6=false) interface = + let conf_file ?(ipv6 = false) interface = let ipv6' = if ipv6 then "6" else "" in - Filename.concat "/var/lib/xcp" (Printf.sprintf "dhclient%s-%s.conf" ipv6' interface) + Filename.concat "/var/lib/xcp" + (Printf.sprintf "dhclient%s-%s.conf" ipv6' interface) - let[@warning "-27"] generate_conf ?(ipv6=false) interface options = + let[@warning "-27"] generate_conf ?(ipv6 = false) interface options = let send = "host-name = gethostname()" in - let minimal = ["subnet-mask"; "broadcast-address"; "time-offset"; "host-name"; "nis-domain"; - "nis-servers"; "ntp-servers"; "interface-mtu"] in + let minimal = + [ + "subnet-mask" + ; "broadcast-address" + ; "time-offset" + ; "host-name" + ; "nis-domain" + ; "nis-servers" + ; "ntp-servers" + ; "interface-mtu" + ] + in let set_gateway = - if List.mem (`gateway interface) options - then (debug "%s is the default gateway interface" interface; ["routers"]) - else (debug "%s is NOT the default gateway interface" interface; []) + if List.mem (`gateway interface) options then ( + debug "%s is the default gateway interface" interface ; + ["routers"] + ) else ( + debug "%s is NOT the default gateway interface" interface ; + [] + ) in let set_dns = - if List.mem (`dns interface) options - then (debug "%s is the DNS interface" interface; ["domain-name"; "domain-name-servers"]) - else (debug "%s is NOT the DNS interface" interface; []) + if List.mem (`dns interface) options then ( + debug "%s is the DNS interface" interface ; + ["domain-name"; "domain-name-servers"] + ) else ( + debug "%s is NOT the DNS interface" interface ; + [] + ) in let request = minimal @ set_gateway @ set_dns in Printf.sprintf "interface \"%s\" {\n send %s;\n request %s;\n}\n" - interface send (String.concat ", " request) + interface send + (String.concat ", " request) - let read_conf_file ?(ipv6=false) interface = + let read_conf_file ?(ipv6 = false) interface = let file = conf_file ~ipv6 interface in try Some (Xapi_stdext_unix.Unixext.string_of_file file) with _ -> None - let write_conf_file ?(ipv6=false) interface options = + let write_conf_file ?(ipv6 = false) interface options = let conf = generate_conf ~ipv6 interface options in - Xapi_stdext_unix.Unixext.write_string_to_file (conf_file ~ipv6 interface) conf + Xapi_stdext_unix.Unixext.write_string_to_file + (conf_file ~ipv6 interface) + conf - let remove_conf_file ?(ipv6=false) interface = + let remove_conf_file ?(ipv6 = false) interface = let file = conf_file ~ipv6 interface in - try - Unix.unlink file - with _ -> () + try Unix.unlink file with _ -> () - let start ?(ipv6=false) interface options = + let start ?(ipv6 = false) interface options = (* If we have a gateway interface, pass it to dhclient-script via -e *) (* This prevents the default route being set erroneously on CentOS *) (* Normally this wouldn't happen as we're not requesting routers, *) (* but some buggy DHCP servers ignore this *) (* Same story for DNS! *) (* See CA-137892 *) - let gw_opt = List.fold_left + let gw_opt = + List.fold_left (fun l x -> - match x with - | `gateway y -> ["-e"; "GATEWAYDEV="^y] - | _ -> l) [] options in - let dns_opt = if List.mem (`dns interface) options then [] else ["-e"; "PEERDNS=no"] in - write_conf_file ~ipv6 interface options; + match x with `gateway y -> ["-e"; "GATEWAYDEV=" ^ y] | _ -> l) + [] options + in + let dns_opt = + if List.mem (`dns interface) options then [] else ["-e"; "PEERDNS=no"] + in + write_conf_file ~ipv6 interface options ; let ipv6' = if ipv6 then ["-6"] else [] in - call_script ~timeout:None dhclient (ipv6' @ gw_opt @ dns_opt @ - ["-q"; - "-pf"; pid_file ~ipv6 interface; - "-lf"; lease_file ~ipv6 interface; - "-cf"; conf_file ~ipv6 interface; - interface]) - - let stop ?(ipv6=false) interface = + call_script ~timeout:None dhclient + (ipv6' + @ gw_opt + @ dns_opt + @ [ + "-q" + ; "-pf" + ; pid_file ~ipv6 interface + ; "-lf" + ; lease_file ~ipv6 interface + ; "-cf" + ; conf_file ~ipv6 interface + ; interface + ] + ) + + let stop ?(ipv6 = false) interface = try - ignore (call_script dhclient ["-r"; - "-pf"; pid_file ~ipv6 interface; - interface]); + ignore + (call_script dhclient + ["-r"; "-pf"; pid_file ~ipv6 interface; interface]) ; Unix.unlink (pid_file ~ipv6 interface) with _ -> () - let is_running ?(ipv6=false) interface = + let is_running ?(ipv6 = false) interface = try - Unix.access (pid_file ~ipv6 interface) [Unix.F_OK]; + Unix.access (pid_file ~ipv6 interface) [Unix.F_OK] ; true - with Unix.Unix_error _ -> - false + with Unix.Unix_error _ -> false - let ensure_running ?(ipv6=false) interface options = - if not(is_running ~ipv6 interface) then + let ensure_running ?(ipv6 = false) interface options = + if not (is_running ~ipv6 interface) then (* dhclient is not running, so we need to start it. *) ignore (start ~ipv6 interface options) - else begin + else (* dhclient is running - if the config has changed, update the config file and restart. *) let current_conf = read_conf_file ~ipv6 interface in let new_conf = generate_conf ~ipv6 interface options in - if current_conf <> (Some new_conf) then begin - ignore (stop ~ipv6 interface); + if current_conf <> Some new_conf then ( + ignore (stop ~ipv6 interface) ; ignore (start ~ipv6 interface options) - end - end + ) end module Fcoe = struct - let call ?log args = - call_script ?log ~timeout:(Some 10.0) !fcoedriver args + let call ?log args = call_script ?log ~timeout:(Some 10.0) !fcoedriver args let get_capabilities name = try let output = call ~log:false ["--xapi"; name; "capable"] in if Astring.String.is_infix ~affix:"True" output then ["fcoe"] else [] with _ -> - debug "Failed to get fcoe support status on device %s" name; + debug "Failed to get fcoe support status on device %s" name ; [] end @@ -848,15 +1013,19 @@ module Sysctl = struct let set_ipv6_autoconf interface value = try - let variables = [ - "net.ipv6.conf." ^ interface ^ ".autoconf"; - "net.ipv6.conf." ^ interface ^ ".accept_ra" - ] in + let variables = + [ + "net.ipv6.conf." ^ interface ^ ".autoconf" + ; "net.ipv6.conf." ^ interface ^ ".accept_ra" + ] + in let value' = if value then "1" else "0" in List.iter (write value') variables with - | e when value = true -> raise e - | _ -> () + | e when value = true -> + raise e + | _ -> + () end module Proc = struct @@ -866,28 +1035,30 @@ module Proc = struct let lines = Astring.String.cuts ~empty:false ~sep:"\n" raw in let check_lines lines = let rec loop current acc = function - | [] -> acc - | line :: tail -> + | [] -> + acc + | line :: tail -> ( try Scanf.sscanf line "%s@: %s@\n" (fun k v -> - if k = "Slave Interface" then begin + if k = "Slave Interface" then let interface = Some (String.trim v) in loop interface acc tail - end else if k = key then + else if k = key then match current with - | Some interface -> loop current ((interface, String.trim v) :: acc) tail - | None -> loop current acc tail + | Some interface -> + loop current ((interface, String.trim v) :: acc) tail + | None -> + loop current acc tail else - loop current acc tail - ) - with _ -> - loop current acc tail + loop current acc tail) + with _ -> loop current acc tail + ) in loop None [] lines in check_lines lines with _ -> - error "Error: could not read %s." (bonding_dir ^ name); + error "Error: could not read %s." (bonding_dir ^ name) ; [] let get_bond_slave_mac name slave = @@ -899,69 +1070,81 @@ module Proc = struct let get_vlans () = try - Xapi_stdext_unix.Unixext.file_lines_fold (fun vlans line -> + Xapi_stdext_unix.Unixext.file_lines_fold + (fun vlans line -> try - let x = Scanf.sscanf line "%s | %d | %s" (fun device vlan parent -> device, vlan, parent) in + let x = + Scanf.sscanf line "%s | %d | %s" (fun device vlan parent -> + (device, vlan, parent)) + in x :: vlans - with _ -> - vlans - ) [] "/proc/net/vlan/config" + with _ -> vlans) + [] "/proc/net/vlan/config" with _ -> - error "Error: could not read /proc/net/vlan/config"; + error "Error: could not read /proc/net/vlan/config" ; [] let get_ipv6_disabled () = try Unixext.string_of_file "/proc/sys/net/ipv6/conf/all/disable_ipv6" |> String.trim - |> (=) "1" + |> ( = ) "1" with _ -> false end module Ovs = struct let match_multiple patterns s = let rec loop = function - | [] -> None - | pattern :: rest -> - match Re.exec_opt pattern s with - | Some groups -> Some groups - | None -> loop rest + | [] -> + None + | pattern :: rest -> ( + match Re.exec_opt pattern s with + | Some groups -> + Some groups + | None -> + loop rest + ) in loop patterns - let patterns = List.map Re.Perl.compile_pat [ - "no bridge named (.*)\n"; - "no row \"(.*)\" in table Bridge" - ] + let patterns = + List.map Re.Perl.compile_pat + ["no bridge named (.*)\n"; "no row \"(.*)\" in table Bridge"] let error_handler script args stdout stderr exn = match match_multiple patterns stderr with | Some groups -> - let bridge = Re.Group.get groups 1 in - raise (Network_error (Bridge_does_not_exist bridge)) + let bridge = Re.Group.get groups 1 in + raise (Network_error (Bridge_does_not_exist bridge)) | None -> - default_error_handler script args stdout stderr exn + default_error_handler script args stdout stderr exn module Cli : sig val vsctl : ?log:bool -> string list -> string + val ofctl : ?log:bool -> string list -> string + val appctl : ?log:bool -> string list -> string end = struct open Xapi_stdext_threads + let s = Semaphore.create 5 + let vsctl ?log args = Semaphore.execute s (fun () -> - call_script ~on_error:error_handler ?log ovs_vsctl ("--timeout=20" :: args) - ) + call_script ~on_error:error_handler ?log ovs_vsctl + ("--timeout=20" :: args)) + let ofctl ?log args = call_script ~on_error:error_handler ?log ovs_ofctl args + let appctl ?log args = call_script ~on_error:error_handler ?log ovs_appctl args end module type Cli_S = module type of Cli - module Make(Cli : Cli_S) = struct + module Make (Cli : Cli_S) = struct include Cli let port_to_interfaces name = @@ -969,11 +1152,19 @@ module Ovs = struct let raw = vsctl ["get"; "port"; name; "interfaces"] in let raw = String.trim raw in if raw <> "[]" then - let raw_list = (Astring.String.cuts ~empty:false ~sep:"," (String.sub raw 1 (String.length raw - 2))) in - let uuids = List.map (String.trim) raw_list in - List.map (fun uuid -> - let raw = String.trim (vsctl ~log:false ["get"; "interface"; uuid; "name"]) in - String.sub raw 1 (String.length raw - 2)) uuids + let raw_list = + Astring.String.cuts ~empty:false ~sep:"," + (String.sub raw 1 (String.length raw - 2)) + in + let uuids = List.map String.trim raw_list in + List.map + (fun uuid -> + let raw = + String.trim + (vsctl ~log:false ["get"; "interface"; uuid; "name"]) + in + String.sub raw 1 (String.length raw - 2)) + uuids else [] with _ -> [] @@ -987,7 +1178,7 @@ module Ovs = struct else [] in - List.map (fun port -> port, port_to_interfaces port) ports' + List.map (fun port -> (port, port_to_interfaces port)) ports' with _ -> [] let bridge_to_interfaces name = @@ -1002,50 +1193,62 @@ module Ovs = struct let bridge_to_vlan name = try let parent = vsctl ~log:false ["br-to-parent"; name] |> String.trim in - let vlan = vsctl ~log:false ["br-to-vlan"; name] |> String.trim |> int_of_string in + let vlan = + vsctl ~log:false ["br-to-vlan"; name] |> String.trim |> int_of_string + in Some (parent, vlan) with e -> - debug "bridge_to_vlan: %s" (Printexc.to_string e); + debug "bridge_to_vlan: %s" (Printexc.to_string e) ; None let get_real_bridge name = match bridge_to_vlan name with - | Some (parent, _vlan) -> parent - | None -> name + | Some (parent, _vlan) -> + parent + | None -> + name let get_bond_link_status name = try let raw = appctl ~log:false ["bond/show"; name] in let lines = Astring.String.cuts ~empty:false ~sep:"\n" raw in - List.fold_left (fun (slaves, active_slave) line -> + List.fold_left + (fun (slaves, active_slave) line -> let slaves = try Scanf.sscanf line "slave %s@: %s" (fun slave state -> - (slave, state = "enabled") :: slaves - ) + (slave, state = "enabled") :: slaves) with _ -> slaves in let active_slave = try - Scanf.sscanf line "active slave %s@(%s@)" (fun _ slave -> Some slave) + Scanf.sscanf line "active slave %s@(%s@)" (fun _ slave -> + Some slave) with _ -> active_slave in - slaves, active_slave - ) ([], None) lines - with _ -> [], None + (slaves, active_slave)) + ([], None) lines + with _ -> ([], None) let get_bond_mode name = try - let output = String.trim (vsctl ~log:false ["get"; "port"; name; "bond_mode"]) in + let output = + String.trim (vsctl ~log:false ["get"; "port"; name; "bond_mode"]) + in if output <> "[]" then Some output else None - with _ -> - None + with _ -> None let set_max_idle t = try - ignore (vsctl ["set"; "Open_vSwitch"; "."; Printf.sprintf "other_config:max-idle=%d" t]) - with _ -> - warn "Failed to set max-idle=%d on OVS" t + ignore + (vsctl + [ + "set" + ; "Open_vSwitch" + ; "." + ; Printf.sprintf "other_config:max-idle=%d" t + ]) + with _ -> warn "Failed to set max-idle=%d on OVS" t let handle_vlan_bug_workaround override bridge = (* This is a list of drivers that do support VLAN tx or rx acceleration, but @@ -1062,33 +1265,51 @@ module Ovs = struct List.filter Sysfs.is_physical interfaces with _ -> [] in - List.iter (fun interface -> + List.iter + (fun interface -> let do_workaround = match override with - | Some value -> value - | None -> + | Some value -> + value + | None -> ( match Sysfs.get_driver_name interface with | None -> - Sysfs.has_vlan_accel interface - | Some driver -> - if List.mem driver no_vlan_workaround_drivers then - false - else Sysfs.has_vlan_accel interface + | Some driver -> + if List.mem driver no_vlan_workaround_drivers then + false + else + Sysfs.has_vlan_accel interface + ) in let setting = if do_workaround then "on" else "off" in - (try - ignore (call_script ovs_vlan_bug_workaround [interface; setting]); - with _ -> ()); - ) phy_interfaces + try ignore (call_script ovs_vlan_bug_workaround [interface; setting]) + with _ -> ()) + phy_interfaces let get_vlans name = try let vlans_with_uuid = - let raw = vsctl ~log:false ["--bare"; "-f"; "table"; "--"; "--columns=name,_uuid"; "find"; "port"; "fake_bridge=true"] in + let raw = + vsctl ~log:false + [ + "--bare" + ; "-f" + ; "table" + ; "--" + ; "--columns=name,_uuid" + ; "find" + ; "port" + ; "fake_bridge=true" + ] + in if raw <> "" then - let lines = Astring.String.cuts ~empty:false ~sep:"\n" (String.trim raw) in - List.map (fun line -> Scanf.sscanf line "%s %s" (fun a b-> a, b)) lines + let lines = + Astring.String.cuts ~empty:false ~sep:"\n" (String.trim raw) + in + List.map + (fun line -> Scanf.sscanf line "%s %s" (fun a b -> (a, b))) + lines else [] in @@ -1096,21 +1317,28 @@ module Ovs = struct let raw = vsctl ~log:false ["get"; "bridge"; name; "ports"] in let raw = String.trim raw in if raw <> "[]" then - let raw_list = (Astring.String.cuts ~empty:false ~sep:"," (String.sub raw 1 (String.length raw - 2))) in + let raw_list = + Astring.String.cuts ~empty:false ~sep:"," + (String.sub raw 1 (String.length raw - 2)) + in List.map String.trim raw_list else [] in - let vlans_on_bridge = List.filter (fun (_, br) -> List.mem br bridge_ports) vlans_with_uuid in + let vlans_on_bridge = + List.filter (fun (_, br) -> List.mem br bridge_ports) vlans_with_uuid + in List.map (fun (n, _) -> n) vlans_on_bridge with _ -> [] let get_bridge_vlan_vifs ~name = try let vlan_fake_bridges = get_vlans name in - List.fold_left(fun vifs br -> + List.fold_left + (fun vifs br -> let vifs' = bridge_to_interfaces br in - vifs' @ vifs) [] vlan_fake_bridges + vifs' @ vifs) + [] vlan_fake_bridges with _ -> [] let get_mcast_snooping_enable ~name = @@ -1124,61 +1352,143 @@ module Ovs = struct try let vvifs = get_bridge_vlan_vifs ~name in let bvifs = bridge_to_interfaces name in - let bvifs' = List.filter (fun vif -> Astring.String.is_prefix ~affix:"vif" vif) bvifs in + let bvifs' = + List.filter + (fun vif -> Astring.String.is_prefix ~affix:"vif" vif) + bvifs + in (* The vifs may be large. However considering current XS limit of 1000VM*7NIC/VM + 800VLANs, the buffer of CLI should be sufficient for lots of vifxxxx.xx *) - fork_script !inject_igmp_query_script (["--no-check-snooping-toggle"; "--max-resp-time"; !igmp_query_maxresp_time] @ bvifs' @ vvifs) + fork_script !inject_igmp_query_script + ([ + "--no-check-snooping-toggle" + ; "--max-resp-time" + ; !igmp_query_maxresp_time + ] + @ bvifs' + @ vvifs + ) with _ -> () let create_port_arg ?ty name bridge = - let type_args = match ty with - | None | Some "" -> [] - | Some s -> ["--"; "set"; "interface"; name; Printf.sprintf "type=%s" s] in + let type_args = + match ty with + | None | Some "" -> + [] + | Some s -> + ["--"; "set"; "interface"; name; Printf.sprintf "type=%s" s] + in ["--"; "--may-exist"; "add-port"; bridge; name] @ type_args - let create_bridge ?mac ?external_id ?disable_in_band ?igmp_snooping ~fail_mode vlan vlan_bug_workaround name = - let vlan_arg = match vlan with - | None -> [] + let create_bridge ?mac ?external_id ?disable_in_band ?igmp_snooping + ~fail_mode vlan vlan_bug_workaround name = + let vlan_arg = + match vlan with + | None -> + [] | Some (parent, tag) -> - handle_vlan_bug_workaround vlan_bug_workaround parent; - [parent; string_of_int tag] + handle_vlan_bug_workaround vlan_bug_workaround parent ; + [parent; string_of_int tag] in - let mac_arg = match mac with - | None -> [] + let mac_arg = + match mac with + | None -> + [] | Some mac -> - if vlan = None then - ["--"; "set"; "bridge"; name; Printf.sprintf "other-config:hwaddr=\"%s\"" (String.escaped mac)] - else - ["--"; "set"; "interface"; name; Printf.sprintf "MAC=\"%s\"" (String.escaped mac)] + if vlan = None then + [ + "--" + ; "set" + ; "bridge" + ; name + ; Printf.sprintf "other-config:hwaddr=\"%s\"" (String.escaped mac) + ] + else + [ + "--" + ; "set" + ; "interface" + ; name + ; Printf.sprintf "MAC=\"%s\"" (String.escaped mac) + ] in let fail_mode_arg = - if vlan = None then ["--"; "set"; "bridge"; name; "fail_mode=" ^ fail_mode] else [] in - let external_id_arg = match external_id with - | None -> [] - | Some (key, value) -> + if vlan = None then + ["--"; "set"; "bridge"; name; "fail_mode=" ^ fail_mode] + else + [] + in + let external_id_arg = + match external_id with + | None -> + [] + | Some (key, value) -> ( match vlan with - | None -> ["--"; "br-set-external-id"; name; key; value] - | Some (parent, _) -> ["--"; "br-set-external-id"; parent; key; value] + | None -> + ["--"; "br-set-external-id"; name; key; value] + | Some (parent, _) -> + ["--"; "br-set-external-id"; parent; key; value] + ) in let disable_in_band_arg = if vlan = None then match disable_in_band with - | None -> [] - | Some None -> ["--"; "remove"; "bridge"; name; "other_config"; "disable-in-band"] - | Some (Some dib) -> ["--"; "set"; "bridge"; name; "other_config:disable-in-band=" ^ dib] + | None -> + [] + | Some None -> + [ + "--"; "remove"; "bridge"; name; "other_config"; "disable-in-band" + ] + | Some (Some dib) -> + [ + "--" + ; "set" + ; "bridge" + ; name + ; "other_config:disable-in-band=" ^ dib + ] else [] in let vif_arg = - let existing_vifs = List.filter (fun iface -> not (Sysfs.is_physical iface)) (bridge_to_interfaces name) in + let existing_vifs = + List.filter + (fun iface -> not (Sysfs.is_physical iface)) + (bridge_to_interfaces name) + in let ifaces_with_type = - let raw = vsctl ~log:false ["--bare"; "-f"; "table"; "--"; "--columns=name,type"; "find"; "interface"; {|type!=\"\"|}] in - let lines = Astring.String.cuts ~empty:false ~sep:"\n" (String.trim raw) in - let parse l = match Astring.String.cut ~sep:" " l with - | Some (k, v) -> let k' = String.trim k and v' = String.trim v in if k' = "" || v' = "" then None else Some(k', v') - | None -> None in + let raw = + vsctl ~log:false + [ + "--bare" + ; "-f" + ; "table" + ; "--" + ; "--columns=name,type" + ; "find" + ; "interface" + ; {|type!=\"\"|} + ] + in + let lines = + Astring.String.cuts ~empty:false ~sep:"\n" (String.trim raw) + in + let parse l = + match Astring.String.cut ~sep:" " l with + | Some (k, v) -> + let k' = String.trim k and v' = String.trim v in + if k' = "" || v' = "" then None else Some (k', v') + | None -> + None + in Xapi_stdext_std.Listext.List.filter_map parse lines in - List.flatten (List.map (fun vif -> create_port_arg ?ty:(List.assoc_opt vif ifaces_with_type) vif name) existing_vifs) + List.flatten + (List.map + (fun vif -> + create_port_arg + ?ty:(List.assoc_opt vif ifaces_with_type) + vif name) + existing_vifs) in let del_old_arg = let real_bridge_exists () = @@ -1197,25 +1507,59 @@ module Ovs = struct in let set_mac_table_size = if vlan = None then - ["--"; "set"; "bridge"; name; "other_config:mac-table-size=" ^ (string_of_int !mac_table_size)] + [ + "--" + ; "set" + ; "bridge" + ; name + ; "other_config:mac-table-size=" ^ string_of_int !mac_table_size + ] else [] in - let set_igmp_snooping = match igmp_snooping, vlan with - | Some x, None -> ["--"; "set"; "bridge"; name; "mcast_snooping_enable=" ^ (string_of_bool x)] - | _ -> [] + let set_igmp_snooping = + match (igmp_snooping, vlan) with + | Some x, None -> + [ + "--" + ; "set" + ; "bridge" + ; name + ; "mcast_snooping_enable=" ^ string_of_bool x + ] + | _ -> + [] in - let set_ipv6_igmp_snooping = match igmp_snooping, vlan with - | Some _, None -> ["--"; "set"; "bridge"; name; "other_config:enable-ipv6-mcast-snooping=" ^ (string_of_bool !enable_ipv6_mcast_snooping)] - | _ -> [] + let set_ipv6_igmp_snooping = + match (igmp_snooping, vlan) with + | Some _, None -> + [ + "--" + ; "set" + ; "bridge" + ; name + ; "other_config:enable-ipv6-mcast-snooping=" + ^ string_of_bool !enable_ipv6_mcast_snooping + ] + | _ -> + [] in - let disable_flood_unregistered = match igmp_snooping, vlan with + let disable_flood_unregistered = + match (igmp_snooping, vlan) with | Some _, None -> - ["--"; "set"; "bridge"; name; "other_config:mcast-snooping-disable-flood-unregistered=" ^ (string_of_bool !mcast_snooping_disable_flood_unregistered)] - | _ -> [] + [ + "--" + ; "set" + ; "bridge" + ; name + ; "other_config:mcast-snooping-disable-flood-unregistered=" + ^ string_of_bool !mcast_snooping_disable_flood_unregistered + ] + | _ -> + [] in - vsctl ( - del_old_arg + vsctl + (del_old_arg @ ["--"; "--may-exist"; "add-br"; name] @ vlan_arg @ mac_arg @@ -1227,10 +1571,9 @@ module Ovs = struct @ set_igmp_snooping @ set_ipv6_igmp_snooping @ disable_flood_unregistered - ) + ) - let destroy_bridge name = - vsctl ["--"; "--if-exists"; "del-br"; name] + let destroy_bridge name = vsctl ["--"; "--if-exists"; "del-br"; name] let list_bridges () = let bridges = String.trim (vsctl ~log:false ["list-br"]) in @@ -1239,7 +1582,7 @@ module Ovs = struct else [] - let create_port ?(internal=false) name bridge = + let create_port ?(internal = false) name bridge = let ty = if internal then Some "internal" else None in vsctl (create_port_arg ?ty name bridge) @@ -1247,22 +1590,48 @@ module Ovs = struct vsctl ["--"; "--with-iface"; "--if-exists"; "del-port"; name] let make_bond_properties name properties = - let known_props = ["mode"; "hashing-algorithm"; "updelay"; "downdelay"; - "miimon"; "use_carrier"; "rebalance-interval"; - "lacp-time"; "lacp-aggregation-key"; "lacp-fallback-ab"] in + let known_props = + [ + "mode" + ; "hashing-algorithm" + ; "updelay" + ; "downdelay" + ; "miimon" + ; "use_carrier" + ; "rebalance-interval" + ; "lacp-time" + ; "lacp-aggregation-key" + ; "lacp-fallback-ab" + ] + in let mode_args = - let mode = if List.mem_assoc "mode" properties - then List.assoc "mode" properties else "balance-slb" in - let halgo = if List.mem_assoc "hashing-algorithm" properties - then List.assoc "hashing-algorithm" properties else "" in - if mode = "lacp" then "lacp=active" :: - (if halgo = "src_mac" then ["bond_mode=balance-slb"] - else if halgo = "tcpudp_ports" then ["bond_mode=balance-tcp"] - else begin - debug "bond %s has invalid bond-hashing-algorithm '%s'; defaulting to balance-tcp" - name halgo; - ["bond_mode=balance-tcp"] - end) + let mode = + if List.mem_assoc "mode" properties then + List.assoc "mode" properties + else + "balance-slb" + in + let halgo = + if List.mem_assoc "hashing-algorithm" properties then + List.assoc "hashing-algorithm" properties + else + "" + in + if mode = "lacp" then + "lacp=active" + :: + ( if halgo = "src_mac" then + ["bond_mode=balance-slb"] + else if halgo = "tcpudp_ports" then + ["bond_mode=balance-tcp"] + else ( + debug + "bond %s has invalid bond-hashing-algorithm '%s'; defaulting to \ + balance-tcp" + name halgo ; + ["bond_mode=balance-tcp"] + ) + ) else ["lacp=off"; "bond_mode=" ^ mode] in @@ -1271,76 +1640,131 @@ module Ovs = struct if List.mem_assoc prop properties then let value = List.assoc prop properties in let value' = try int_of_string value with _ -> -1 in - if value' < 0 then begin - debug "bond %s has invalid %s '%s'\n" name prop value; + if value' < 0 then ( + debug "bond %s has invalid %s '%s'\n" name prop value ; [] - end else if prop = "use_carrier" then - [ovs_key ^ "=" ^ (if value' > 0 then "carrier" else "miimon")] + ) else if prop = "use_carrier" then + [(ovs_key ^ "=" ^ if value' > 0 then "carrier" else "miimon")] else - [ovs_key ^ "=" ^ (string_of_int value')] + [ovs_key ^ "=" ^ string_of_int value'] else [] and get_prop (prop, ovs_key) = - if List.mem_assoc prop properties - then let value = List.assoc prop properties in + if List.mem_assoc prop properties then + let value = List.assoc prop properties in [ovs_key ^ "=\"" ^ value ^ "\""] - else [] + else + [] in (* Don't add new properties here, these use the legacy converter *) - let extra_args_legacy = List.flatten (List.map get_prop_legacy - ["updelay", "bond_updelay"; "downdelay", "bond_downdelay"; - "miimon", "other-config:bond-miimon-interval"; - "use_carrier", "other-config:bond-detect-mode"; - "rebalance-interval", "other-config:bond-rebalance-interval";]) - and extra_args = List.flatten (List.map get_prop - ["lacp-time", "other-config:lacp-time"; - "lacp-fallback-ab", "other-config:lacp-fallback-ab";]) - and per_iface_args = List.flatten (List.map get_prop - ["lacp-aggregation-key", "other-config:lacp-aggregation-key"; - "lacp-actor-key", "other-config:lacp-actor-key";]) - and other_args = Xapi_stdext_std.Listext.List.filter_map (fun (k, v) -> - if List.mem k known_props then None - else Some (Printf.sprintf "other-config:\"%s\"=\"%s\"" - (String.escaped ("bond-" ^ k)) (String.escaped v)) - ) properties in + let extra_args_legacy = + List.flatten + (List.map get_prop_legacy + [ + ("updelay", "bond_updelay") + ; ("downdelay", "bond_downdelay") + ; ("miimon", "other-config:bond-miimon-interval") + ; ("use_carrier", "other-config:bond-detect-mode") + ; ("rebalance-interval", "other-config:bond-rebalance-interval") + ]) + and extra_args = + List.flatten + (List.map get_prop + [ + ("lacp-time", "other-config:lacp-time") + ; ("lacp-fallback-ab", "other-config:lacp-fallback-ab") + ]) + and per_iface_args = + List.flatten + (List.map get_prop + [ + ("lacp-aggregation-key", "other-config:lacp-aggregation-key") + ; ("lacp-actor-key", "other-config:lacp-actor-key") + ]) + and other_args = + Xapi_stdext_std.Listext.List.filter_map + (fun (k, v) -> + if List.mem k known_props then + None + else + Some + (Printf.sprintf "other-config:\"%s\"=\"%s\"" + (String.escaped ("bond-" ^ k)) + (String.escaped v))) + properties + in (mode_args @ extra_args_legacy @ extra_args @ other_args, per_iface_args) let create_bond ?mac name interfaces bridge properties = let args, per_iface_args = make_bond_properties name properties in - let mac_args = match mac with - | None -> [] - | Some mac -> ["--"; "set"; "port"; name; "MAC=\"" ^ (String.escaped mac) ^ "\""] + let mac_args = + match mac with + | None -> + [] + | Some mac -> + ["--"; "set"; "port"; name; "MAC=\"" ^ String.escaped mac ^ "\""] in let per_iface_args = - if per_iface_args = [] - then [] - else List.flatten + if per_iface_args = [] then + [] + else + List.flatten (List.map - (fun iface -> - ["--"; "set"; "interface"; iface ] @ per_iface_args) + (fun iface -> ["--"; "set"; "interface"; iface] @ per_iface_args) interfaces) in - vsctl (["--"; "--may-exist"; "add-bond"; bridge; name] @ interfaces @ - mac_args @ args @ per_iface_args) + vsctl + (["--"; "--may-exist"; "add-bond"; bridge; name] + @ interfaces + @ mac_args + @ args + @ per_iface_args + ) - let get_fail_mode bridge = - vsctl ~log:false ["get-fail-mode"; bridge] + let get_fail_mode bridge = vsctl ~log:false ["get-fail-mode"; bridge] let add_default_flows bridge mac interfaces = - let ports = List.map (fun interface -> vsctl ["get"; "interface"; interface; "ofport"]) interfaces in - let flows = match ports with + let ports = + List.map + (fun interface -> vsctl ["get"; "interface"; interface; "ofport"]) + interfaces + in + let flows = + match ports with | [port] -> - [Printf.sprintf "idle_timeout=0,priority=0,in_port=%s,arp,nw_proto=1,actions=local" port; - Printf.sprintf "idle_timeout=0,priority=0,in_port=local,arp,dl_src=%s,actions=%s" mac port; - Printf.sprintf "idle_timeout=0,priority=0,in_port=%s,dl_dst=%s,actions=local" port mac; - Printf.sprintf "idle_timeout=0,priority=0,in_port=local,dl_src=%s,actions=%s" mac port] + [ + Printf.sprintf + "idle_timeout=0,priority=0,in_port=%s,arp,nw_proto=1,actions=local" + port + ; Printf.sprintf + "idle_timeout=0,priority=0,in_port=local,arp,dl_src=%s,actions=%s" + mac port + ; Printf.sprintf + "idle_timeout=0,priority=0,in_port=%s,dl_dst=%s,actions=local" + port mac + ; Printf.sprintf + "idle_timeout=0,priority=0,in_port=local,dl_src=%s,actions=%s" + mac port + ] | ports -> - List.flatten (List.map (fun port -> - [Printf.sprintf "idle_timeout=0,priority=0,in_port=local,arp,dl_src=%s,actions=NORMAL" mac; - Printf.sprintf "idle_timeout=0,priority=0,in_port=local,dl_src=%s,actions=NORMAL" mac; - Printf.sprintf "idle_timeout=0,priority=0,in_port=%s,arp,nw_proto=1,actions=local" port; - Printf.sprintf "idle_timeout=0,priority=0,in_port=%s,dl_dst=%s,actions=local" port mac] - ) ports) + List.flatten + (List.map + (fun port -> + [ + Printf.sprintf + "idle_timeout=0,priority=0,in_port=local,arp,dl_src=%s,actions=NORMAL" + mac + ; Printf.sprintf + "idle_timeout=0,priority=0,in_port=local,dl_src=%s,actions=NORMAL" + mac + ; Printf.sprintf + "idle_timeout=0,priority=0,in_port=%s,arp,nw_proto=1,actions=local" + port + ; Printf.sprintf + "idle_timeout=0,priority=0,in_port=%s,dl_dst=%s,actions=local" + port mac + ]) + ports) in List.iter (fun flow -> ignore (ofctl ["add-flow"; bridge; flow])) flows @@ -1349,14 +1773,13 @@ module Ovs = struct let set_mtu interface mtu = vsctl ["set"; "interface"; interface; Printf.sprintf "mtu_request=%d" mtu] - end - include Make(Cli) + + include Make (Cli) end module Brctl = struct - let call args = - call_script !brctl args + let call args = call_script !brctl args let create_bridge name = if not (List.mem name (Sysfs.list ())) then @@ -1379,64 +1802,85 @@ module Brctl = struct end module Ethtool = struct - let call args = - call_script !ethtool args + let call args = call_script !ethtool args let set_options name options = if options <> [] then - ignore (call ("-s" :: name :: (List.concat (List.map (fun (k, v) -> [k; v]) options)))) + ignore + (call + ("-s" + :: name + :: List.concat (List.map (fun (k, v) -> [k; v]) options) + )) let set_offload name options = if options <> [] then - ignore (call ("-K" :: name :: (List.concat (List.map (fun (k, v) -> [k; v]) options)))) + ignore + (call + ("-K" + :: name + :: List.concat (List.map (fun (k, v) -> [k; v]) options) + )) end module Dracut = struct - let call args = - call_script ~timeout:(Some !dracut_timeout) !dracut args + let call args = call_script ~timeout:(Some !dracut_timeout) !dracut args let rebuild_initrd () = try - info "Building initrd..."; + info "Building initrd..." ; let img_name = call_script !uname ["-r"] |> String.trim in - call ["-f"; Printf.sprintf "/boot/initrd-%s.img" img_name; img_name] |> ignore; + call ["-f"; Printf.sprintf "/boot/initrd-%s.img" img_name; img_name] + |> ignore ; Result.Ok () - with _ -> Result.Error (Fail_to_rebuild_initrd, "Error occurs in building initrd") + with _ -> + Result.Error (Fail_to_rebuild_initrd, "Error occurs in building initrd") end module Modinfo = struct - let call args = - call_script !modinfo args + let call args = call_script !modinfo args let is_param_array driver param_name = try - let out = call ["--parameter"; driver] - |> String.trim |> String.split_on_char '\n' + let out = + call ["--parameter"; driver] |> String.trim |> String.split_on_char '\n' in let re = Re.Perl.compile_pat "\\((.*)\\)$" in let has_array_of str = match Re.exec_opt re str with - | None -> false - | Some x -> Re.Group.get x 1 |> Astring.String.is_infix ~affix:"array of" + | None -> + false + | Some x -> + Re.Group.get x 1 |> Astring.String.is_infix ~affix:"array of" in - Ok (List.exists (fun line -> - match Astring.String.cut ~sep:":" line with - | None -> false - | Some (param, description) -> String.trim param = param_name && has_array_of description - ) out + Ok + (List.exists + (fun line -> + match Astring.String.cut ~sep:":" line with + | None -> + false + | Some (param, description) -> + String.trim param = param_name && has_array_of description) + out) + with _ -> + Error + ( Other + , Printf.sprintf + "Failed to determine if VF param of driver '%s' is an array" driver ) - with _ -> Error (Other, Printf.sprintf "Failed to determine if VF param of driver '%s' is an array" driver) end module Modprobe = struct - let getpath driver = - Printf.sprintf "/etc/modprobe.d/%s.conf" driver + let getpath driver = Printf.sprintf "/etc/modprobe.d/%s.conf" driver let write_conf_file driver content = try - Unixext.write_string_to_file (getpath driver) (String.concat "\n" content); + Unixext.write_string_to_file (getpath driver) (String.concat "\n" content) ; Result.Ok () - with _ -> Result.Error (Fail_to_write_modprobe_cfg, "Failed to write modprobe configuration file for: " ^ driver) + with _ -> + Result.Error + ( Fail_to_write_modprobe_cfg + , "Failed to write modprobe configuration file for: " ^ driver ) (* For a igb driver, the module config file will be at path `/etc/modprobe.d/igb.conf` @@ -1457,15 +1901,20 @@ module Modprobe = struct let open Xapi_stdext_std.Listext in Unixext.read_lines ~path:(getpath driver) |> List.filter_map (fun x -> - let line = String.trim x in - if not (Astring.String.is_prefix ~affix:("# ") line) - then None - else - match Astring.String.cut ~sep:":" (Astring.String.with_range ~first:2 line) with - | None -> None - | Some (k, v) when String.trim k = "" || String.trim v = "" -> None - | Some (k, v) -> Some (String.trim k, String.trim v) - ) + let line = String.trim x in + if not (Astring.String.is_prefix ~affix:"# " line) then + None + else + match + Astring.String.cut ~sep:":" + (Astring.String.with_range ~first:2 line) + with + | None -> + None + | Some (k, v) when String.trim k = "" || String.trim v = "" -> + None + | Some (k, v) -> + Some (String.trim k, String.trim v)) with _ -> [] (* this function not returning None means that the driver doesn't suppport sysfs. @@ -1474,25 +1923,25 @@ module Modprobe = struct not None, the driver definitely should use modprobe other than sysfs, and if Modprobe.get_vf_param is None, we just simple try sysfs. *) let get_vf_param config = - try - Some (List.assoc "VFs-param" config) - with _ -> None + try Some (List.assoc "VFs-param" config) with _ -> None let get_maxvfs driver config = let get_default_maxvfs config = - try - Some (List.assoc "VFs-maxvfs-by-default" config |> int_of_string) + try Some (List.assoc "VFs-maxvfs-by-default" config |> int_of_string) with _ -> None in let get_user_defined_maxvfs config = - try - Some (List.assoc "VFs-maxvfs-by-user" config |> int_of_string) + try Some (List.assoc "VFs-maxvfs-by-user" config |> int_of_string) with _ -> None in - match get_default_maxvfs config, get_user_defined_maxvfs config with - | Some a, None -> Result.Ok a - | Some a, Some b -> Result.Ok (min a b) (* If users also define a maxvfs, we will use the smaller one *) - | _ -> Result.Error (Fail_to_get_maxvfs, "Fail to get maxvfs for "^ driver) + match (get_default_maxvfs config, get_user_defined_maxvfs config) with + | Some a, None -> + Result.Ok a + | Some a, Some b -> + Result.Ok (min a b) + (* If users also define a maxvfs, we will use the smaller one *) + | _ -> + Result.Error (Fail_to_get_maxvfs, "Fail to get maxvfs for " ^ driver) let config_sriov driver vf_param maxvfs = let open Rresult.R.Infix in @@ -1501,49 +1950,64 @@ module Modprobe = struct in the configuration an array like `options igb max_vfs=7,7,7,7` or a single value like `options igb max_vfs=7`. If an array is required, this repeat times equals to the number of devices with the same driver. - *) - let repeat = if is_array then Sysfs.get_dev_nums_with_same_driver driver else 1 in - begin - if repeat > 0 then Result.Ok ( - Array.make repeat (string_of_int maxvfs) + *) + let repeat = + if is_array then Sysfs.get_dev_nums_with_same_driver driver else 1 + in + ( if repeat > 0 then + Result.Ok + (Array.make repeat (string_of_int maxvfs) |> Array.to_list - |> String.concat ",") - else Result.Error (Other, "Fail to generate options for maxvfs for " ^ driver) - end >>= fun option -> + |> String.concat "," + ) + else + Result.Error (Other, "Fail to generate options for maxvfs for " ^ driver) + ) + >>= fun option -> let need_rebuild_initrd = ref false in let has_probe_conf = ref false in let parse_single_line s = let parse_driver_options s = - match Astring.String.cut ~sep:"=" s with + match Astring.String.cut ~sep:"=" s with (* has SR-IOV configuration but the max_vfs is exactly what we want to set, so no changes and return s *) - | Some (k, v) when k = vf_param && v = option -> has_probe_conf := true; s + | Some (k, v) when k = vf_param && v = option -> + has_probe_conf := true ; + s (* has SR-IOV configuration and we need change it to expected option *) | Some (k, v) when k = vf_param -> - has_probe_conf := true; - need_rebuild_initrd := true; - debug "change SR-IOV options from [%s=%s] to [%s=%s]" k v k option; - Printf.sprintf "%s=%s" vf_param option + has_probe_conf := true ; + need_rebuild_initrd := true ; + debug "change SR-IOV options from [%s=%s] to [%s=%s]" k v k option ; + Printf.sprintf "%s=%s" vf_param option (* we do not care the lines without SR-IOV configurations *) - | _ -> s + | _ -> + s in let trimed_s = String.trim s in - if Re.execp (Re.Perl.compile_pat ("options[ \\t]+" ^ driver)) trimed_s then - let driver_options = Re.split (Re.Perl.compile_pat "[ \\t]+") trimed_s in - List.map parse_driver_options driver_options - |> String.concat " " + if Re.execp (Re.Perl.compile_pat ("options[ \\t]+" ^ driver)) trimed_s + then + let driver_options = + Re.split (Re.Perl.compile_pat "[ \\t]+") trimed_s + in + List.map parse_driver_options driver_options |> String.concat " " else trimed_s in let lines = try Unixext.read_lines ~path:(getpath driver) with _ -> [] in let new_conf = List.map parse_single_line lines in - match !has_probe_conf, !need_rebuild_initrd with + match (!has_probe_conf, !need_rebuild_initrd) with | true, true -> - write_conf_file driver new_conf >>= fun () -> - Dracut.rebuild_initrd () + write_conf_file driver new_conf >>= fun () -> Dracut.rebuild_initrd () | false, false -> - let new_option_line = Printf.sprintf "options %s %s=%s" driver vf_param option in - write_conf_file driver (new_conf @ [new_option_line]) >>= fun () -> - Dracut.rebuild_initrd () - | true, false -> Result.Ok () (* already have modprobe configuration and no need to change *) - | false, true -> Result.Error (Other, "enabling SR-IOV via modprobe never comes here for: " ^ driver) + let new_option_line = + Printf.sprintf "options %s %s=%s" driver vf_param option + in + write_conf_file driver (new_conf @ [new_option_line]) >>= fun () -> + Dracut.rebuild_initrd () + | true, false -> + Result.Ok () + (* already have modprobe configuration and no need to change *) + | false, true -> + Result.Error + (Other, "enabling SR-IOV via modprobe never comes here for: " ^ driver) end diff --git a/networkd/network_monitor.ml b/networkd/network_monitor.ml index a894fcfc3..edf82b87f 100644 --- a/networkd/network_monitor.ml +++ b/networkd/network_monitor.ml @@ -15,8 +15,10 @@ include Network_stats let write_stats stats = - let payload = stats |> Rpcmarshal.marshal typ_of_stats_t |> Jsonrpc.to_string in + let payload = + stats |> Rpcmarshal.marshal typ_of_stats_t |> Jsonrpc.to_string + in let checksum = payload |> Digest.string |> Digest.to_hex in let length = String.length payload in let data = Printf.sprintf "%s%s%08x%s" magic checksum length payload in - Xapi_stdext_unix.Unixext.write_string_to_file stats_file (data) + Xapi_stdext_unix.Unixext.write_string_to_file stats_file data diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index 3fc124faf..945a5d975 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -13,80 +13,99 @@ *) open Network_utils - open Xapi_stdext_pervasives open Xapi_stdext_threads.Threadext -module D = Debug.Make(struct let name = "network_monitor_thread" end) +module D = Debug.Make (struct let name = "network_monitor_thread" end) + open D (** Table for bonds status. *) -let bonds_status : (string, (int * int)) Hashtbl.t = Hashtbl.create 10 +let bonds_status : (string, int * int) Hashtbl.t = Hashtbl.create 10 -let monitor_whitelist = ref [ - "eth"; - "vif"; (* This includes "tap" owing to the use of standardise_name below *) - ] +let monitor_whitelist = + ref + [ + "eth" + ; "vif" + (* This includes "tap" owing to the use of standardise_name below *) + ] let xapi_rpc xml = let open Xmlrpc_client in - XMLRPC_protocol.rpc ~srcstr:"xcp-networkd" ~dststr:"xapi" ~transport:(Unix "/var/xapi/xapi") ~http:(xmlrpc ~version:"1.0" "/") xml + XMLRPC_protocol.rpc ~srcstr:"xcp-networkd" ~dststr:"xapi" + ~transport:(Unix "/var/xapi/xapi") + ~http:(xmlrpc ~version:"1.0" "/") + xml let send_bond_change_alert _dev interfaces message = let ifaces = String.concat "+" (List.sort String.compare interfaces) in let module XenAPI = Client.Client in - let session_id = XenAPI.Session.login_with_password - ~rpc:xapi_rpc ~uname:"" ~pwd:"" ~version:"1.4" ~originator:("xcp-networkd v" ^ Version.version) in + let session_id = + XenAPI.Session.login_with_password ~rpc:xapi_rpc ~uname:"" ~pwd:"" + ~version:"1.4" + ~originator:("xcp-networkd v" ^ Version.version) + in Pervasiveext.finally (fun _ -> - let obj_uuid = Inventory.lookup Inventory._installation_uuid in - let body = Printf.sprintf "The status of the %s bond %s" ifaces message in - try - let (name, priority) = Api_messages.bond_status_changed in - let (_ : API.ref_message) = XenAPI.Message.create ~rpc:xapi_rpc ~session_id - ~name ~priority ~cls:`Host ~obj_uuid ~body in () - with _ -> - warn "Exception sending a bond-status-change alert." - ) + let obj_uuid = Inventory.lookup Inventory._installation_uuid in + let body = Printf.sprintf "The status of the %s bond %s" ifaces message in + try + let name, priority = Api_messages.bond_status_changed in + let (_ : API.ref_message) = + XenAPI.Message.create ~rpc:xapi_rpc ~session_id ~name ~priority + ~cls:`Host ~obj_uuid ~body + in + () + with _ -> warn "Exception sending a bond-status-change alert.") (fun _ -> XenAPI.Session.logout ~rpc:xapi_rpc ~session_id) let check_for_changes ~(dev : string) ~(stat : Network_monitor.iface_stats) = let open Network_monitor in - match Astring.String.is_prefix ~affix:"vif" dev with true -> () | false -> - if stat.nb_links > 1 then ( (* It is a bond. *) - if Hashtbl.mem bonds_status dev then ( (* Seen before. *) - let nb_links_old, links_up_old = Hashtbl.find bonds_status dev in - if links_up_old <> stat.links_up then ( - info "Bonds status changed: %s nb_links %d up %d up_old %d" dev stat.nb_links - stat.links_up links_up_old; - Hashtbl.replace bonds_status dev (stat.nb_links,stat.links_up); - let msg = Printf.sprintf "changed: %d/%d up (was %d/%d)" stat.links_up stat.nb_links - links_up_old nb_links_old in - try - send_bond_change_alert dev stat.interfaces msg - with e -> - debug "Error while sending alert BONDS_STATUS_CHANGED: %s\n%s" - (Printexc.to_string e) (Printexc.get_backtrace ()) + match Astring.String.is_prefix ~affix:"vif" dev with + | true -> + () + | false -> + if stat.nb_links > 1 then + if (* It is a bond. *) + Hashtbl.mem bonds_status dev then ( + (* Seen before. *) + let nb_links_old, links_up_old = Hashtbl.find bonds_status dev in + if links_up_old <> stat.links_up then ( + info "Bonds status changed: %s nb_links %d up %d up_old %d" dev + stat.nb_links stat.links_up links_up_old ; + Hashtbl.replace bonds_status dev (stat.nb_links, stat.links_up) ; + let msg = + Printf.sprintf "changed: %d/%d up (was %d/%d)" stat.links_up + stat.nb_links links_up_old nb_links_old + in + try send_bond_change_alert dev stat.interfaces msg + with e -> + debug "Error while sending alert BONDS_STATUS_CHANGED: %s\n%s" + (Printexc.to_string e) + (Printexc.get_backtrace ()) + ) + ) else ( + (* Seen for the first time. *) + Hashtbl.add bonds_status dev (stat.nb_links, stat.links_up) ; + info "New bonds status: %s nb_links %d up %d" dev stat.nb_links + stat.links_up ; + if stat.links_up <> stat.nb_links then + let msg = + Printf.sprintf "is: %d/%d up" stat.links_up stat.nb_links + in + try send_bond_change_alert dev stat.interfaces msg + with e -> + debug "Error while sending alert BONDS_STATUS_CHANGED: %s\n%s" + (Printexc.to_string e) + (Printexc.get_backtrace ()) ) - ) else ( (* Seen for the first time. *) - Hashtbl.add bonds_status dev (stat.nb_links,stat.links_up); - info "New bonds status: %s nb_links %d up %d" dev stat.nb_links stat.links_up; - if stat.links_up <> stat.nb_links then - (let msg = Printf.sprintf "is: %d/%d up" stat.links_up stat.nb_links in - try - send_bond_change_alert dev stat.interfaces msg - with e -> - debug "Error while sending alert BONDS_STATUS_CHANGED: %s\n%s" - (Printexc.to_string e) (Printexc.get_backtrace ())) - ) - ) let failed_again = ref false let standardise_name name = try - let (d1,d2) = Scanf.sscanf name "tap%d.%d" - (fun d1 d2 -> d1,d2) in + let d1, d2 = Scanf.sscanf name "tap%d.%d" (fun d1 d2 -> (d1, d2)) in let newname = Printf.sprintf "vif%d.%d" d1 d2 in newname with _ -> name @@ -95,174 +114,242 @@ let get_link_stats () = let open Network_monitor in let open Netlink in let s = Socket.alloc () in - Socket.connect s Socket.NETLINK_ROUTE; - + Socket.connect s Socket.NETLINK_ROUTE ; let cache = Link.cache_alloc s in let links = Link.cache_to_list cache in let links = let is_whitelisted name = - List.exists (fun s -> Astring.String.is_prefix ~affix:s name) !monitor_whitelist + List.exists + (fun s -> Astring.String.is_prefix ~affix:s name) + !monitor_whitelist in let is_vlan name = Astring.String.is_prefix ~affix:"eth" name && String.contains name '.' in - List.map (fun link -> - (standardise_name (Link.get_name link)), link - ) links |> - (* Only keep interfaces with prefixes on the whitelist, and exclude VLAN - devices (ethx.y). *) - List.filter (fun (name, _) -> - is_whitelisted name && not (is_vlan name) - ) + List.map (fun link -> (standardise_name (Link.get_name link), link)) links + |> (* Only keep interfaces with prefixes on the whitelist, and exclude VLAN + devices (ethx.y). *) + List.filter (fun (name, _) -> is_whitelisted name && not (is_vlan name)) in - - let devs = List.map (fun (name,link) -> - let convert x = Int64.of_int (Unsigned.UInt64.to_int x) in - let eth_stat = {default_stats with - rx_bytes = Link.get_stat link Link.RX_BYTES |> convert; - rx_pkts = Link.get_stat link Link.RX_PACKETS |> convert; - rx_errors = Link.get_stat link Link.RX_ERRORS |> convert; - tx_bytes = Link.get_stat link Link.TX_BYTES |> convert; - tx_pkts = Link.get_stat link Link.TX_PACKETS |> convert; - tx_errors = Link.get_stat link Link.TX_ERRORS |> convert; - } in - name, eth_stat - ) links in - - Cache.free cache; - Socket.close s; - Socket.free s; - devs + let devs = + List.map + (fun (name, link) -> + let convert x = Int64.of_int (Unsigned.UInt64.to_int x) in + let eth_stat = + { + default_stats with + rx_bytes= Link.get_stat link Link.RX_BYTES |> convert + ; rx_pkts= Link.get_stat link Link.RX_PACKETS |> convert + ; rx_errors= Link.get_stat link Link.RX_ERRORS |> convert + ; tx_bytes= Link.get_stat link Link.TX_BYTES |> convert + ; tx_pkts= Link.get_stat link Link.TX_PACKETS |> convert + ; tx_errors= Link.get_stat link Link.TX_ERRORS |> convert + } + in + (name, eth_stat)) + links + in + Cache.free cache ; Socket.close s ; Socket.free s ; devs let rec monitor dbg () = let open Network_interface in let open Network_monitor in - (try - let make_bond_info devs (name, interfaces) = - let devs' = List.filter (fun (name', _) -> List.mem name' interfaces) devs in - let eth_stat = {default_stats with - rx_bytes = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.rx_bytes) 0L devs'; - rx_pkts = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.rx_pkts) 0L devs'; - rx_errors = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.rx_errors) 0L devs'; - tx_bytes = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.tx_bytes) 0L devs'; - tx_pkts = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.tx_pkts) 0L devs'; - tx_errors = List.fold_left (fun ac (_, stat) -> Int64.add ac stat.tx_errors) 0L devs'; - } in - name, eth_stat - in - let add_bonds bonds devs = - (List.map (make_bond_info devs) bonds) @ devs - in - let transform_taps devs = - let newdevnames = Xapi_stdext_std.Listext.List.setify (List.map fst devs) in - List.map (fun name -> - let devs' = List.filter (fun (n,_) -> n=name) devs in - let tot = List.fold_left (fun acc (_,b) -> - {default_stats with - rx_bytes = Int64.add acc.rx_bytes b.rx_bytes; - rx_pkts = Int64.add acc.rx_pkts b.rx_pkts; - rx_errors = Int64.add acc.rx_errors b.rx_errors; - tx_bytes = Int64.add acc.tx_bytes b.tx_bytes; - tx_pkts = Int64.add acc.tx_pkts b.tx_pkts; - tx_errors = Int64.add acc.tx_errors b.tx_errors} - ) default_stats devs' in - (name,tot) - ) newdevnames - in - let add_other_stats bonds devs = - List.map (fun (dev, stat) -> - if not (Astring.String.is_prefix ~affix:"vif" dev) then begin - let open Network_server.Bridge in - let bond_slaves = - if List.mem_assoc dev bonds then - get_bond_link_info () dbg ~name:dev - else - [] - in - let stat = - if bond_slaves = [] then - let carrier = Sysfs.get_carrier dev in - let speed, duplex = - if carrier then - Sysfs.get_status dev - else - (0, Duplex_unknown) - in - let pci_bus_path = Sysfs.get_pcibuspath dev in - let vendor_id, device_id = Sysfs.get_pci_ids dev in - let nb_links = 1 in - let links_up = if carrier then 1 else 0 in - let interfaces = [dev] in - {stat with carrier; speed; duplex; pci_bus_path; vendor_id; device_id; nb_links; links_up; interfaces} - else - let carrier = List.exists (fun info -> info.up) bond_slaves in - let speed, duplex = - let combine_duplex = function - | Duplex_full, Duplex_full -> Duplex_full - | Duplex_unknown, a | a, Duplex_unknown -> a - | _ -> Duplex_half - in - List.fold_left (fun (speed, duplex) info -> - try - if info.active then - let speed', duplex' = Sysfs.get_status info.slave in - speed + speed', combine_duplex (duplex, duplex') - else - speed, duplex - with _ -> - speed, duplex - ) (0, Duplex_unknown) bond_slaves - in - let pci_bus_path = "" in - let vendor_id, device_id = "", "" in - let nb_links = List.length bond_slaves in - let links_up = List.length (List.filter (fun info -> info.up) bond_slaves) in - let interfaces = List.map (fun info -> info.slave) bond_slaves in - {stat with carrier; speed; duplex; pci_bus_path; vendor_id; device_id; nb_links; links_up; interfaces} - in - check_for_changes ~dev ~stat; - dev, stat - end else - dev, stat - ) devs - in - let from_cache = true in - let bonds : (string * string list) list = Network_server.Bridge.get_all_bonds dbg from_cache in - let devs = - get_link_stats () |> - add_bonds bonds |> - transform_taps |> - add_other_stats bonds - in - - if (List.length bonds) <> (Hashtbl.length bonds_status) then begin - let dead_bonds = Hashtbl.fold (fun k _ acc -> if List.mem_assoc k bonds then acc else k :: acc) - bonds_status [] in - List.iter (fun b -> info "Removing bond %s" b; Hashtbl.remove bonds_status b) dead_bonds - end; - - write_stats devs; - failed_again := false - with e -> - if not !failed_again then begin - failed_again := true; - debug "Error while collecting stats (suppressing further errors): %s\n%s" - (Printexc.to_string e) (Printexc.get_backtrace ()) - end - ); - - Thread.delay interval; - monitor dbg () + ( try + let make_bond_info devs (name, interfaces) = + let devs' = + List.filter (fun (name', _) -> List.mem name' interfaces) devs + in + let eth_stat = + { + default_stats with + rx_bytes= + List.fold_left + (fun ac (_, stat) -> Int64.add ac stat.rx_bytes) + 0L devs' + ; rx_pkts= + List.fold_left + (fun ac (_, stat) -> Int64.add ac stat.rx_pkts) + 0L devs' + ; rx_errors= + List.fold_left + (fun ac (_, stat) -> Int64.add ac stat.rx_errors) + 0L devs' + ; tx_bytes= + List.fold_left + (fun ac (_, stat) -> Int64.add ac stat.tx_bytes) + 0L devs' + ; tx_pkts= + List.fold_left + (fun ac (_, stat) -> Int64.add ac stat.tx_pkts) + 0L devs' + ; tx_errors= + List.fold_left + (fun ac (_, stat) -> Int64.add ac stat.tx_errors) + 0L devs' + } + in + (name, eth_stat) + in + let add_bonds bonds devs = List.map (make_bond_info devs) bonds @ devs in + let transform_taps devs = + let newdevnames = + Xapi_stdext_std.Listext.List.setify (List.map fst devs) + in + List.map + (fun name -> + let devs' = List.filter (fun (n, _) -> n = name) devs in + let tot = + List.fold_left + (fun acc (_, b) -> + { + default_stats with + rx_bytes= Int64.add acc.rx_bytes b.rx_bytes + ; rx_pkts= Int64.add acc.rx_pkts b.rx_pkts + ; rx_errors= Int64.add acc.rx_errors b.rx_errors + ; tx_bytes= Int64.add acc.tx_bytes b.tx_bytes + ; tx_pkts= Int64.add acc.tx_pkts b.tx_pkts + ; tx_errors= Int64.add acc.tx_errors b.tx_errors + }) + default_stats devs' + in + (name, tot)) + newdevnames + in + let add_other_stats bonds devs = + List.map + (fun (dev, stat) -> + if not (Astring.String.is_prefix ~affix:"vif" dev) then ( + let open Network_server.Bridge in + let bond_slaves = + if List.mem_assoc dev bonds then + get_bond_link_info () dbg ~name:dev + else + [] + in + let stat = + if bond_slaves = [] then + let carrier = Sysfs.get_carrier dev in + let speed, duplex = + if carrier then + Sysfs.get_status dev + else + (0, Duplex_unknown) + in + let pci_bus_path = Sysfs.get_pcibuspath dev in + let vendor_id, device_id = Sysfs.get_pci_ids dev in + let nb_links = 1 in + let links_up = if carrier then 1 else 0 in + let interfaces = [dev] in + { + stat with + carrier + ; speed + ; duplex + ; pci_bus_path + ; vendor_id + ; device_id + ; nb_links + ; links_up + ; interfaces + } + else + let carrier = List.exists (fun info -> info.up) bond_slaves in + let speed, duplex = + let combine_duplex = function + | Duplex_full, Duplex_full -> + Duplex_full + | Duplex_unknown, a | a, Duplex_unknown -> + a + | _ -> + Duplex_half + in + List.fold_left + (fun (speed, duplex) info -> + try + if info.active then + let speed', duplex' = Sysfs.get_status info.slave in + (speed + speed', combine_duplex (duplex, duplex')) + else + (speed, duplex) + with _ -> (speed, duplex)) + (0, Duplex_unknown) bond_slaves + in + let pci_bus_path = "" in + let vendor_id, device_id = ("", "") in + let nb_links = List.length bond_slaves in + let links_up = + List.length (List.filter (fun info -> info.up) bond_slaves) + in + let interfaces = + List.map (fun info -> info.slave) bond_slaves + in + { + stat with + carrier + ; speed + ; duplex + ; pci_bus_path + ; vendor_id + ; device_id + ; nb_links + ; links_up + ; interfaces + } + in + check_for_changes ~dev ~stat ; + (dev, stat) + ) else + (dev, stat)) + devs + in + let from_cache = true in + let bonds : (string * string list) list = + Network_server.Bridge.get_all_bonds dbg from_cache + in + let devs = + get_link_stats () + |> add_bonds bonds + |> transform_taps + |> add_other_stats bonds + in + ( if List.length bonds <> Hashtbl.length bonds_status then + let dead_bonds = + Hashtbl.fold + (fun k _ acc -> if List.mem_assoc k bonds then acc else k :: acc) + bonds_status [] + in + List.iter + (fun b -> + info "Removing bond %s" b ; + Hashtbl.remove bonds_status b) + dead_bonds + ) ; + write_stats devs ; + failed_again := false + with e -> + if not !failed_again then ( + failed_again := true ; + debug + "Error while collecting stats (suppressing further errors): %s\n%s" + (Printexc.to_string e) + (Printexc.get_backtrace ()) + ) + ) ; + Thread.delay interval ; monitor dbg () let watcher_m = Mutex.create () + let watcher_pid = ref None let signal_networking_change () = let module XenAPI = Client.Client in - let session = XenAPI.Session.slave_local_login_with_password ~rpc:xapi_rpc ~uname:"" ~pwd:"" in + let session = + XenAPI.Session.slave_local_login_with_password ~rpc:xapi_rpc ~uname:"" + ~pwd:"" + in Pervasiveext.finally - (fun () -> XenAPI.Host.signal_networking_change ~rpc:xapi_rpc - ~session_id:session) + (fun () -> + XenAPI.Host.signal_networking_change ~rpc:xapi_rpc ~session_id:session) (fun () -> XenAPI.Session.local_logout ~rpc:xapi_rpc ~session_id:session) (* Remove all outstanding reads on a file descriptor *) @@ -270,70 +357,74 @@ let clear_input fd = let buf = Bytes.make 255 ' ' in let rec loop () = try - ignore (Unix.read fd buf 0 255); + ignore (Unix.read fd buf 0 255) ; loop () with _ -> () in - Unix.set_nonblock fd; - loop (); - Unix.clear_nonblock fd + Unix.set_nonblock fd ; loop () ; Unix.clear_nonblock fd let rec ip_watcher () = let cmd = Network_utils.iproute2 in let args = ["monitor"; "address"] in let readme, writeme = Unix.pipe () in Mutex.execute watcher_m (fun () -> - watcher_pid := Some (Forkhelpers.safe_close_and_exec ~env:(Unix.environment ()) None (Some writeme) None [] cmd args) - ); - Unix.close writeme; + watcher_pid := + Some + (Forkhelpers.safe_close_and_exec ~env:(Unix.environment ()) None + (Some writeme) None [] cmd args)) ; + Unix.close writeme ; let in_channel = Unix.in_channel_of_descr readme in let rec loop () = let line = input_line in_channel in (* Do not send events for link-local IPv6 addresses, and removed IPs *) - if Astring.String.is_infix ~affix:"inet" line && not (Astring.String.is_infix ~affix:"inet6 fe80" line) then begin + if + Astring.String.is_infix ~affix:"inet" line + && not (Astring.String.is_infix ~affix:"inet6 fe80" line) + then ( (* Ignore changes for the next second, since they usually come in bursts, * and signal only once. *) - Thread.delay 1.; - clear_input readme; + Thread.delay 1. ; + clear_input readme ; signal_networking_change () - end; + ) ; loop () in - let restart_ip_watcher () = begin - Unix.close readme; - Thread.delay 5.0; - ip_watcher (); - end + let restart_ip_watcher () = + Unix.close readme ; Thread.delay 5.0 ; ip_watcher () in while true do try - info "(Re)started IP watcher thread"; + info "(Re)started IP watcher thread" ; loop () - with e -> - warn "Error in IP watcher: %s\n%s" (Printexc.to_string e) (Printexc.get_backtrace ()); + with e -> ( + warn "Error in IP watcher: %s\n%s" (Printexc.to_string e) + (Printexc.get_backtrace ()) ; match !watcher_pid with - | None -> restart_ip_watcher () - | Some pid -> - let quitted, _ = Forkhelpers.waitpid_nohang pid in - if quitted <> 0 then begin - warn "address monitoring process quitted, try to restart it"; + | None -> restart_ip_watcher () - end + | Some pid -> + let quitted, _ = Forkhelpers.waitpid_nohang pid in + if quitted <> 0 then ( + warn "address monitoring process quitted, try to restart it" ; + restart_ip_watcher () + ) + ) done let start () = let dbg = "monitor_thread" in - Debug.with_thread_associated dbg (fun () -> - debug "Starting network monitor"; + Debug.with_thread_associated dbg + (fun () -> + debug "Starting network monitor" ; let (_ : Thread.t) = Thread.create (monitor dbg) () in let (_ : Thread.t) = Thread.create ip_watcher () in - () - ) () + ()) + () let stop () = Mutex.execute watcher_m (fun () -> match !watcher_pid with - | None -> () - | Some pid -> Unix.kill (Forkhelpers.getpid pid) Sys.sigterm - ) - + | None -> + () + | Some pid -> + Unix.kill (Forkhelpers.getpid pid) Sys.sigterm) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 82f151c6c..5c55ccc05 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -16,80 +16,84 @@ open Network_utils open Network_interface open Xapi_stdext_monadic -module S = Network_interface.Interface_API(Idl.Exn.GenServer ()) -module D = Debug.Make(struct let name = "network_server" end) +module S = Network_interface.Interface_API (Idl.Exn.GenServer ()) + +module D = Debug.Make (struct let name = "network_server" end) + open D type context = unit let network_conf = ref "/etc/xcp/network.conf" + let config : config_t ref = ref Network_config.empty_config + let backend_kind = ref Openvswitch let write_config () = - try - Network_config.write_config !config + try Network_config.write_config !config with Network_config.Write_error -> () let read_config () = try - config := Network_config.read_config (); + config := Network_config.read_config () ; debug "Read configuration from networkd.db file." - with Network_config.Read_error -> - (* No configuration file found. Try to get the initial network setup from - * the first-boot data written by the host installer. *) + with Network_config.Read_error -> ( try - config := Network_config.read_management_conf (); + (* No configuration file found. Try to get the initial network setup from + * the first-boot data written by the host installer. *) + config := Network_config.read_management_conf () ; debug "Read configuration from management.conf file." with Network_config.Read_error -> debug "Could not interpret the configuration in management.conf" + ) let on_shutdown signal = let dbg = "shutdown" in - Debug.with_thread_associated dbg (fun () -> - debug "xcp-networkd caught signal %d; performing cleanup actions." signal; - write_config () - ) () + Debug.with_thread_associated dbg + (fun () -> + debug "xcp-networkd caught signal %d; performing cleanup actions." signal ; + write_config ()) + () -let on_timer () = - write_config () +let on_timer () = write_config () -let clear_state () = - config := Network_config.empty_config +let clear_state () = config := Network_config.empty_config -let reset_state () = - config := Network_config.read_management_conf () +let reset_state () = config := Network_config.read_management_conf () let set_gateway_interface _dbg name = (* Remove dhclient conf (if any) for the old and new gateway interfaces. * This ensures that dhclient gets restarted with an updated conf file when * necessary. *) - begin match !config.gateway_interface with - | Some old_iface when name <> old_iface -> - Dhclient.remove_conf_file name; + ( match !config.gateway_interface with + | Some old_iface when name <> old_iface -> + Dhclient.remove_conf_file name ; Dhclient.remove_conf_file old_iface - | _ -> () - end; - debug "Setting gateway interface to %s" name; - config := {!config with gateway_interface = Some name} + | _ -> + () + ) ; + debug "Setting gateway interface to %s" name ; + config := {!config with gateway_interface= Some name} let set_dns_interface _dbg name = (* Remove dhclient conf (if any) for the old and new DNS interfaces. * This ensures that dhclient gets restarted with an updated conf file when * necessary. *) - begin match !config.dns_interface with + ( match !config.dns_interface with | Some old_iface when name <> old_iface -> - Dhclient.remove_conf_file name; - Dhclient.remove_conf_file old_iface - | _ -> () - end; - debug "Setting DNS interface to %s" name; - config := {!config with dns_interface = Some name} + Dhclient.remove_conf_file name ; + Dhclient.remove_conf_file old_iface + | _ -> + () + ) ; + debug "Setting DNS interface to %s" name ; + config := {!config with dns_interface= Some name} (* The enic driver is for Cisco UCS devices. The current driver adds VLAN0 headers * to all incoming packets, which confuses certain guests OSes. The workaround * constitutes adding a VLAN0 Linux device to strip those headers again. -*) + *) let need_enic_workaround () = !backend_kind = Bridge && List.mem "enic" (Sysfs.list_drivers ()) @@ -100,91 +104,112 @@ module Sriov = struct let open Rresult.R.Infix in let maxvfs_modprobe = Sysfs.get_driver_name_err dev >>= fun driver -> - Modprobe.get_config_from_comments driver - |> Modprobe.get_maxvfs driver + Modprobe.get_config_from_comments driver |> Modprobe.get_maxvfs driver and maxvfs_sysfs = Sysfs.get_sriov_maxvfs dev in let is_support = - match maxvfs_modprobe, maxvfs_sysfs with - | Ok v, _ -> v > 0 - | Error _ , Ok v -> v > 0 - | _ -> false + match (maxvfs_modprobe, maxvfs_sysfs) with + | Ok v, _ -> + v > 0 + | Error _, Ok v -> + v > 0 + | _ -> + false in if is_support then ["sriov"] else [] - let config_sriov ~enable dev = + let config_sriov ~enable dev = let op = if enable then "enable" else "disable" in let open Rresult.R.Infix in Sysfs.get_driver_name_err dev >>= fun driver -> let config = Modprobe.get_config_from_comments driver in match Modprobe.get_vf_param config with | Some vf_param -> - debug "%s SR-IOV on a device: %s via modprobe" op dev; - (if enable then Modprobe.get_maxvfs driver config else Ok 0) >>= fun numvfs -> - (* CA-287340: Even if the current numvfs equals to the target numvfs, - it is still needed to update SR-IOV modprobe config file, as the - SR-IOV enabing takes effect after reboot. For example, a user - enables SR-IOV and disables it immediately without a reboot.*) - Modprobe.config_sriov driver vf_param numvfs >>= fun _ -> - if numvfs = Sysfs.get_sriov_numvfs dev then - Ok Modprobe_successful - else - Ok Modprobe_successful_requires_reboot + debug "%s SR-IOV on a device: %s via modprobe" op dev ; + (if enable then Modprobe.get_maxvfs driver config else Ok 0) + >>= fun numvfs -> + (* CA-287340: Even if the current numvfs equals to the target numvfs, + it is still needed to update SR-IOV modprobe config file, as the + SR-IOV enabing takes effect after reboot. For example, a user + enables SR-IOV and disables it immediately without a reboot.*) + Modprobe.config_sriov driver vf_param numvfs >>= fun _ -> + if numvfs = Sysfs.get_sriov_numvfs dev then + Ok Modprobe_successful + else + Ok Modprobe_successful_requires_reboot | None -> - debug "%s SR-IOV on a device: %s via sysfs" op dev; - begin - if enable then Sysfs.get_sriov_maxvfs dev - else Sysfs.unbind_child_vfs dev >>= fun () -> Ok 0 - end >>= fun numvfs -> - Sysfs.set_sriov_numvfs dev numvfs >>= fun _ -> - Ok Sysfs_successful + debug "%s SR-IOV on a device: %s via sysfs" op dev ; + ( if enable then + Sysfs.get_sriov_maxvfs dev + else + Sysfs.unbind_child_vfs dev >>= fun () -> Ok 0 + ) + >>= fun numvfs -> + Sysfs.set_sriov_numvfs dev numvfs >>= fun _ -> Ok Sysfs_successful let enable dbg name = - Debug.with_thread_associated dbg (fun () -> - debug "Enable network SR-IOV by name: %s" name; + Debug.with_thread_associated dbg + (fun () -> + debug "Enable network SR-IOV by name: %s" name ; match config_sriov ~enable:true name with - | Ok t -> (Ok t:enable_result) - | Result.Error (_, msg) -> warn "Failed to enable SR-IOV on %s with error: %s" name msg; Error msg - ) () + | Ok t -> + (Ok t : enable_result) + | Result.Error (_, msg) -> + warn "Failed to enable SR-IOV on %s with error: %s" name msg ; + Error msg) + () let disable dbg name = - Debug.with_thread_associated dbg (fun () -> - debug "Disable network SR-IOV by name: %s" name; + Debug.with_thread_associated dbg + (fun () -> + debug "Disable network SR-IOV by name: %s" name ; match config_sriov ~enable:false name with - | Ok _ -> (Ok:disable_result) - | Result.Error (_, msg) -> warn "Failed to disable SR-IOV on %s with error: %s" name msg; Error msg - ) () + | Ok _ -> + (Ok : disable_result) + | Result.Error (_, msg) -> + warn "Failed to disable SR-IOV on %s with error: %s" name msg ; + Error msg) + () let make_vf_conf_internal pcibuspath mac vlan rate = let config_or_otherwise_reset config_f reset_f = function - | None -> reset_f () - | Some a -> config_f a + | None -> + reset_f () + | Some a -> + config_f a in let open Rresult.R.Infix in Sysfs.parent_device_of_vf pcibuspath >>= fun dev -> Sysfs.device_index_of_vf dev pcibuspath >>= fun index -> config_or_otherwise_reset (Ip.set_vf_mac dev index) - (fun () -> Result.Ok ()) mac >>= fun () -> + (fun () -> Result.Ok ()) + mac + >>= fun () -> (* In order to ensure the Networkd to be idempotent, configuring VF with no VLAN and rate have to reset vlan and rate, since the VF might have previous configuration. Refering to http://gittup.org/cgi-bin/man/man2html?ip-link+8, set VLAN and rate to 0 means to reset them *) config_or_otherwise_reset (Ip.set_vf_vlan dev index) - (fun () -> Ip.set_vf_vlan dev index 0) vlan >>= fun () -> + (fun () -> Ip.set_vf_vlan dev index 0) + vlan + >>= fun () -> config_or_otherwise_reset (Ip.set_vf_rate dev index) - (fun () -> Ip.set_vf_rate dev index 0) rate + (fun () -> Ip.set_vf_rate dev index 0) + rate let make_vf_config dbg pci_address (vf_info : sriov_pci_t) = - Debug.with_thread_associated dbg (fun () -> + Debug.with_thread_associated dbg + (fun () -> let vlan = Opt.map Int64.to_int vf_info.vlan and rate = Opt.map Int64.to_int vf_info.rate and pcibuspath = Xcp_pci.string_of_address pci_address in - debug "Config VF with pci address: %s" pcibuspath; + debug "Config VF with pci address: %s" pcibuspath ; match make_vf_conf_internal pcibuspath vf_info.mac vlan rate with - | Result.Ok () -> (Ok:config_result) + | Result.Ok () -> + (Ok : config_result) | Result.Error (Fail_to_set_vf_rate, msg) -> - debug "%s" msg; - Error Config_vf_rate_not_supported - | Result.Error (_, msg) -> debug "%s" msg; Error (Unknown msg) - ) () + debug "%s" msg ; Error Config_vf_rate_not_supported + | Result.Error (_, msg) -> + debug "%s" msg ; Error (Unknown msg)) + () end module Interface = struct @@ -192,437 +217,613 @@ module Interface = struct get_config !config.interface_config default_interface name let update_config name data = - config := {!config with interface_config = update_config !config.interface_config name data} + config := + { + !config with + interface_config= update_config !config.interface_config name data + } let get_all dbg () = - Debug.with_thread_associated dbg (fun () -> - Sysfs.list () - ) () + Debug.with_thread_associated dbg (fun () -> Sysfs.list ()) () let exists dbg name = - Debug.with_thread_associated dbg (fun () -> - List.mem name (Sysfs.list ()) - ) () + Debug.with_thread_associated dbg + (fun () -> List.mem name (Sysfs.list ())) + () let get_mac dbg name = - Debug.with_thread_associated dbg (fun () -> + Debug.with_thread_associated dbg + (fun () -> match Linux_bonding.get_bond_master_of name with - | Some master -> Proc.get_bond_slave_mac master name - | None -> Ip.get_mac name - ) () + | Some master -> + Proc.get_bond_slave_mac master name + | None -> + Ip.get_mac name) + () + let get_pci_bus_path dbg name = - Debug.with_thread_associated dbg (fun () -> - Sysfs.get_pcibuspath name - ) () + Debug.with_thread_associated dbg (fun () -> Sysfs.get_pcibuspath name) () let is_up dbg name = - Debug.with_thread_associated dbg (fun () -> + Debug.with_thread_associated dbg + (fun () -> if List.mem name (Sysfs.list ()) then Ip.is_up name else - false - ) () + false) + () let get_ipv4_addr dbg name = - Debug.with_thread_associated dbg (fun () -> - Ip.get_ipv4 name - ) () + Debug.with_thread_associated dbg (fun () -> Ip.get_ipv4 name) () let set_ipv4_conf dbg name conf = - Debug.with_thread_associated dbg (fun () -> - debug "Configuring IPv4 address for %s: %s" name (conf |> Rpcmarshal.marshal typ_of_ipv4 |> Jsonrpc.to_string); - update_config name {(get_config name) with ipv4_conf = conf}; + Debug.with_thread_associated dbg + (fun () -> + debug "Configuring IPv4 address for %s: %s" name + (conf |> Rpcmarshal.marshal typ_of_ipv4 |> Jsonrpc.to_string) ; + update_config name {(get_config name) with ipv4_conf= conf} ; match conf with | None4 -> - if List.mem name (Sysfs.list ()) then begin - if Dhclient.is_running name then - ignore (Dhclient.stop name); - Ip.flush_ip_addr name - end + if List.mem name (Sysfs.list ()) then ( + if Dhclient.is_running name then + ignore (Dhclient.stop name) ; + Ip.flush_ip_addr name + ) | DHCP4 -> - let open Xapi_stdext_monadic in - let gateway = Opt.default [] (Opt.map (fun n -> [`gateway n]) !config.gateway_interface) in - let dns = Opt.default [] (Opt.map (fun n -> [`dns n]) !config.dns_interface) in - let options = gateway @ dns in - Dhclient.ensure_running name options + let open Xapi_stdext_monadic in + let gateway = + Opt.default [] + (Opt.map (fun n -> [`gateway n]) !config.gateway_interface) + in + let dns = + Opt.default [] (Opt.map (fun n -> [`dns n]) !config.dns_interface) + in + let options = gateway @ dns in + Dhclient.ensure_running name options | Static4 addrs -> - if Dhclient.is_running name then begin - ignore (Dhclient.stop name); - Ip.flush_ip_addr name - end; - (* the function is meant to be idempotent and we - * want to avoid CA-239919 *) - let cur_addrs = Ip.get_ipv4 name in - let rm_addrs = Xapi_stdext_std.Listext.List.set_difference cur_addrs addrs in - let add_addrs = Xapi_stdext_std.Listext.List.set_difference addrs cur_addrs in - List.iter (Ip.del_ip_addr name) rm_addrs; - List.iter (Ip.set_ip_addr name) add_addrs - ) () + if Dhclient.is_running name then ( + ignore (Dhclient.stop name) ; + Ip.flush_ip_addr name + ) ; + (* the function is meant to be idempotent and we + * want to avoid CA-239919 *) + let cur_addrs = Ip.get_ipv4 name in + let rm_addrs = + Xapi_stdext_std.Listext.List.set_difference cur_addrs addrs + in + let add_addrs = + Xapi_stdext_std.Listext.List.set_difference addrs cur_addrs + in + List.iter (Ip.del_ip_addr name) rm_addrs ; + List.iter (Ip.set_ip_addr name) add_addrs) + () let get_ipv4_gateway dbg name = - Debug.with_thread_associated dbg (fun () -> + Debug.with_thread_associated dbg + (fun () -> let output = Ip.route_show ~version:Ip.V4 name in try - let line = List.find (fun s -> Astring.String.is_prefix ~affix:"default via" s) (Astring.String.cuts ~empty:false ~sep:"\n" output) in - let addr = List.nth (Astring.String.cuts ~empty:false ~sep:" " line) 2 in + let line = + List.find + (fun s -> Astring.String.is_prefix ~affix:"default via" s) + (Astring.String.cuts ~empty:false ~sep:"\n" output) + in + let addr = + List.nth (Astring.String.cuts ~empty:false ~sep:" " line) 2 + in Some (Unix.inet_addr_of_string addr) - with Not_found -> None - ) () + with Not_found -> None) + () let set_ipv4_gateway _ dbg ~name ~address = - Debug.with_thread_associated dbg (fun () -> - debug "Configuring IPv4 gateway for %s: %s" name (Unix.string_of_inet_addr address); - update_config name {(get_config name) with ipv4_gateway = Some address}; - if !config.gateway_interface = None || !config.gateway_interface = Some name then begin - debug "%s is the default gateway interface" name; + Debug.with_thread_associated dbg + (fun () -> + debug "Configuring IPv4 gateway for %s: %s" name + (Unix.string_of_inet_addr address) ; + update_config name {(get_config name) with ipv4_gateway= Some address} ; + if + !config.gateway_interface = None + || !config.gateway_interface = Some name + then ( + debug "%s is the default gateway interface" name ; Ip.set_gateway name address - end else - debug "%s is NOT the default gateway interface" name - ) () + ) else + debug "%s is NOT the default gateway interface" name) + () let get_ipv6_addr dbg name = - Debug.with_thread_associated dbg (fun () -> - Ip.get_ipv6 name - ) () + Debug.with_thread_associated dbg (fun () -> Ip.get_ipv6 name) () let set_ipv6_conf _ dbg ~name ~conf = - Debug.with_thread_associated dbg (fun () -> - if Proc.get_ipv6_disabled () then - warn "Not configuring IPv6 address for %s (IPv6 is disabled)" name - else begin - debug "Configuring IPv6 address for %s: %s" name (conf |> Rpcmarshal.marshal typ_of_ipv6 |> Jsonrpc.to_string); - update_config name {(get_config name) with ipv6_conf = conf}; - match conf with - | None6 -> - if List.mem name (Sysfs.list ()) then begin - if Dhclient.is_running ~ipv6:true name then - ignore (Dhclient.stop ~ipv6:true name); - Sysctl.set_ipv6_autoconf name false; - Ip.flush_ip_addr ~ipv6:true name - end - | Linklocal6 -> - if List.mem name (Sysfs.list ()) then begin - if Dhclient.is_running ~ipv6:true name then - ignore (Dhclient.stop ~ipv6:true name); - Sysctl.set_ipv6_autoconf name false; - Ip.flush_ip_addr ~ipv6:true name; - Ip.set_ipv6_link_local_addr name - end - | DHCP6 -> - if Dhclient.is_running ~ipv6:true name then - ignore (Dhclient.stop ~ipv6:true name); - Sysctl.set_ipv6_autoconf name false; - Ip.flush_ip_addr ~ipv6:true name; - Ip.set_ipv6_link_local_addr name; - ignore (Dhclient.ensure_running ~ipv6:true name []) - | Autoconf6 -> - if Dhclient.is_running ~ipv6:true name then - ignore (Dhclient.stop ~ipv6:true name); - Ip.flush_ip_addr ~ipv6:true name; - Ip.set_ipv6_link_local_addr name; - Sysctl.set_ipv6_autoconf name true; - (* Cannot link set down/up due to CA-89882 - IPv4 default route cleared *) - | Static6 addrs -> - if Dhclient.is_running ~ipv6:true name then - ignore (Dhclient.stop ~ipv6:true name); - Sysctl.set_ipv6_autoconf name false; - (* add the link_local and clean the old one only when needed *) - let cur_addrs = - let addrs = Ip.get_ipv6 name in - let maybe_link_local = Ip.split_addr (Ip.get_ipv6_link_local_addr name) in - match maybe_link_local with - | Some addr -> Xapi_stdext_std.Listext.List.setify (addr :: addrs) - | None -> addrs - in - let rm_addrs = Xapi_stdext_std.Listext.List.set_difference cur_addrs addrs in - let add_addrs = Xapi_stdext_std.Listext.List.set_difference addrs cur_addrs in - List.iter (Ip.del_ip_addr name) rm_addrs; - List.iter (Ip.set_ip_addr name) add_addrs - end - ) () + Debug.with_thread_associated dbg + (fun () -> + if Proc.get_ipv6_disabled () then + warn "Not configuring IPv6 address for %s (IPv6 is disabled)" name + else ( + debug "Configuring IPv6 address for %s: %s" name + (conf |> Rpcmarshal.marshal typ_of_ipv6 |> Jsonrpc.to_string) ; + update_config name {(get_config name) with ipv6_conf= conf} ; + match conf with + | None6 -> + if List.mem name (Sysfs.list ()) then ( + if Dhclient.is_running ~ipv6:true name then + ignore (Dhclient.stop ~ipv6:true name) ; + Sysctl.set_ipv6_autoconf name false ; + Ip.flush_ip_addr ~ipv6:true name + ) + | Linklocal6 -> + if List.mem name (Sysfs.list ()) then ( + if Dhclient.is_running ~ipv6:true name then + ignore (Dhclient.stop ~ipv6:true name) ; + Sysctl.set_ipv6_autoconf name false ; + Ip.flush_ip_addr ~ipv6:true name ; + Ip.set_ipv6_link_local_addr name + ) + | DHCP6 -> + if Dhclient.is_running ~ipv6:true name then + ignore (Dhclient.stop ~ipv6:true name) ; + Sysctl.set_ipv6_autoconf name false ; + Ip.flush_ip_addr ~ipv6:true name ; + Ip.set_ipv6_link_local_addr name ; + ignore (Dhclient.ensure_running ~ipv6:true name []) + | Autoconf6 -> + if Dhclient.is_running ~ipv6:true name then + ignore (Dhclient.stop ~ipv6:true name) ; + Ip.flush_ip_addr ~ipv6:true name ; + Ip.set_ipv6_link_local_addr name ; + Sysctl.set_ipv6_autoconf name true + (* Cannot link set down/up due to CA-89882 - IPv4 default route cleared *) + | Static6 addrs -> + if Dhclient.is_running ~ipv6:true name then + ignore (Dhclient.stop ~ipv6:true name) ; + Sysctl.set_ipv6_autoconf name false ; + (* add the link_local and clean the old one only when needed *) + let cur_addrs = + let addrs = Ip.get_ipv6 name in + let maybe_link_local = + Ip.split_addr (Ip.get_ipv6_link_local_addr name) + in + match maybe_link_local with + | Some addr -> + Xapi_stdext_std.Listext.List.setify (addr :: addrs) + | None -> + addrs + in + let rm_addrs = + Xapi_stdext_std.Listext.List.set_difference cur_addrs addrs + in + let add_addrs = + Xapi_stdext_std.Listext.List.set_difference addrs cur_addrs + in + List.iter (Ip.del_ip_addr name) rm_addrs ; + List.iter (Ip.set_ip_addr name) add_addrs + )) + () let set_ipv6_gateway _ dbg ~name ~address = - Debug.with_thread_associated dbg (fun () -> - if Proc.get_ipv6_disabled () then - warn "Not configuring IPv6 gateway for %s (IPv6 is disabled)" name - else begin - debug "Configuring IPv6 gateway for %s: %s" name (Unix.string_of_inet_addr address); - update_config name {(get_config name) with ipv6_gateway = Some address}; - if !config.gateway_interface = None || !config.gateway_interface = Some name then begin - debug "%s is the default gateway interface" name; - Ip.set_gateway name address - end else - debug "%s is NOT the default gateway interface" name - end - ) () + Debug.with_thread_associated dbg + (fun () -> + if Proc.get_ipv6_disabled () then + warn "Not configuring IPv6 gateway for %s (IPv6 is disabled)" name + else ( + debug "Configuring IPv6 gateway for %s: %s" name + (Unix.string_of_inet_addr address) ; + update_config name {(get_config name) with ipv6_gateway= Some address} ; + if + !config.gateway_interface = None + || !config.gateway_interface = Some name + then ( + debug "%s is the default gateway interface" name ; + Ip.set_gateway name address + ) else + debug "%s is NOT the default gateway interface" name + )) + () let set_ipv4_routes _ dbg ~name ~routes = - Debug.with_thread_associated dbg (fun () -> - debug "Configuring IPv4 static routes for %s: %s" name (String.concat ", " (List.map (fun r -> - Printf.sprintf "%s/%d/%s" (Unix.string_of_inet_addr r.subnet) r.netmask (Unix.string_of_inet_addr r.gateway)) routes)); - update_config name {(get_config name) with ipv4_routes = routes}; - List.iter (fun r -> Ip.set_route ~network:(r.subnet, r.netmask) name r.gateway) routes - ) () + Debug.with_thread_associated dbg + (fun () -> + debug "Configuring IPv4 static routes for %s: %s" name + (String.concat ", " + (List.map + (fun r -> + Printf.sprintf "%s/%d/%s" + (Unix.string_of_inet_addr r.subnet) + r.netmask + (Unix.string_of_inet_addr r.gateway)) + routes)) ; + update_config name {(get_config name) with ipv4_routes= routes} ; + List.iter + (fun r -> Ip.set_route ~network:(r.subnet, r.netmask) name r.gateway) + routes) + () let get_dns dbg _name = - Debug.with_thread_associated dbg (fun () -> - let nameservers, domains = Xapi_stdext_unix.Unixext.file_lines_fold (fun (nameservers, domains) line -> - if Astring.String.is_prefix ~affix:"nameserver" line then - let server = List.nth (Astring.String.fields ~empty:false line) 1 in - (Unix.inet_addr_of_string server) :: nameservers, domains - else if Astring.String.is_prefix ~affix:"search" line then - let domains = List.tl (Astring.String.fields ~empty:false line) in - nameservers, domains - else - nameservers, domains - ) ([], []) resolv_conf in - List.rev nameservers, domains - ) () + Debug.with_thread_associated dbg + (fun () -> + let nameservers, domains = + Xapi_stdext_unix.Unixext.file_lines_fold + (fun (nameservers, domains) line -> + if Astring.String.is_prefix ~affix:"nameserver" line then + let server = + List.nth (Astring.String.fields ~empty:false line) 1 + in + (Unix.inet_addr_of_string server :: nameservers, domains) + else if Astring.String.is_prefix ~affix:"search" line then + let domains = + List.tl (Astring.String.fields ~empty:false line) + in + (nameservers, domains) + else + (nameservers, domains)) + ([], []) resolv_conf + in + (List.rev nameservers, domains)) + () let set_dns _ dbg ~name ~nameservers ~domains = - Debug.with_thread_associated dbg (fun () -> - update_config name {(get_config name) with dns = nameservers, domains}; + Debug.with_thread_associated dbg + (fun () -> + update_config name {(get_config name) with dns= (nameservers, domains)} ; debug "Configuring DNS for %s: nameservers: [%s]; domains: [%s]" name (String.concat ", " (List.map Unix.string_of_inet_addr nameservers)) - (String.concat ", " domains); - if (!config.dns_interface = None || !config.dns_interface = Some name) then begin - debug "%s is the DNS interface" name; - let domains' = if domains <> [] then ["search " ^ (String.concat " " domains)] else [] in - let nameservers' = List.map (fun ip -> "nameserver " ^ (Unix.string_of_inet_addr ip)) nameservers in + (String.concat ", " domains) ; + if !config.dns_interface = None || !config.dns_interface = Some name + then ( + debug "%s is the DNS interface" name ; + let domains' = + if domains <> [] then + ["search " ^ String.concat " " domains] + else + [] + in + let nameservers' = + List.map + (fun ip -> "nameserver " ^ Unix.string_of_inet_addr ip) + nameservers + in let lines = domains' @ nameservers' in - Xapi_stdext_unix.Unixext.write_string_to_file resolv_conf ((String.concat "\n" lines) ^ "\n") - end else - debug "%s is NOT the DNS interface" name - ) () + Xapi_stdext_unix.Unixext.write_string_to_file resolv_conf + (String.concat "\n" lines ^ "\n") + ) else + debug "%s is NOT the DNS interface" name) + () let get_mtu dbg name = - Debug.with_thread_associated dbg (fun () -> - Ip.get_mtu name - ) () + Debug.with_thread_associated dbg (fun () -> Ip.get_mtu name) () let set_mtu _ dbg ~name ~mtu = - Debug.with_thread_associated dbg (fun () -> - debug "Configuring MTU for %s: %d" name mtu; - update_config name {(get_config name) with mtu}; + Debug.with_thread_associated dbg + (fun () -> + debug "Configuring MTU for %s: %d" name mtu ; + update_config name {(get_config name) with mtu} ; match !backend_kind with - | Openvswitch -> - (try - ignore (Ovs.set_mtu name mtu) - with _ -> - Ip.link_set_mtu name mtu) - | Bridge -> Ip.link_set_mtu name mtu - ) () + | Openvswitch -> ( + try ignore (Ovs.set_mtu name mtu) with _ -> Ip.link_set_mtu name mtu + ) + | Bridge -> + Ip.link_set_mtu name mtu) + () let set_ethtool_settings _ dbg ~name ~params = - Debug.with_thread_associated dbg (fun () -> + Debug.with_thread_associated dbg + (fun () -> debug "Configuring ethtool settings for %s: %s" name - (String.concat ", " (List.map (fun (k, v) -> k ^ "=" ^ v) params)); - let add_defaults = List.filter (fun (k, _) -> not (List.mem_assoc k params)) default_interface.ethtool_settings in + (String.concat ", " (List.map (fun (k, v) -> k ^ "=" ^ v) params)) ; + let add_defaults = + List.filter + (fun (k, _) -> not (List.mem_assoc k params)) + default_interface.ethtool_settings + in let params = params @ add_defaults in - update_config name {(get_config name) with ethtool_settings = params}; - Ethtool.set_options name params - ) () + update_config name {(get_config name) with ethtool_settings= params} ; + Ethtool.set_options name params) + () let set_ethtool_offload _ dbg ~name ~params = - Debug.with_thread_associated dbg (fun () -> + Debug.with_thread_associated dbg + (fun () -> debug "Configuring ethtool offload settings for %s: %s" name - (String.concat ", " (List.map (fun (k, v) -> k ^ "=" ^ v) params)); - let add_defaults = List.filter (fun (k, _) -> not (List.mem_assoc k params)) default_interface.ethtool_offload in + (String.concat ", " (List.map (fun (k, v) -> k ^ "=" ^ v) params)) ; + let add_defaults = + List.filter + (fun (k, _) -> not (List.mem_assoc k params)) + default_interface.ethtool_offload + in let params = params @ add_defaults in - update_config name {(get_config name) with ethtool_offload = params}; - Ethtool.set_offload name params - ) () + update_config name {(get_config name) with ethtool_offload= params} ; + Ethtool.set_offload name params) + () let get_capabilities dbg name = - Debug.with_thread_associated dbg (fun () -> - Fcoe.get_capabilities name @ Sriov.get_capabilities name - ) () + Debug.with_thread_associated dbg + (fun () -> Fcoe.get_capabilities name @ Sriov.get_capabilities name) + () let is_connected dbg name = - Debug.with_thread_associated dbg (fun () -> - Sysfs.get_carrier name - ) () + Debug.with_thread_associated dbg (fun () -> Sysfs.get_carrier name) () let is_physical dbg name = - Debug.with_thread_associated dbg (fun () -> - Sysfs.is_physical name - ) () + Debug.with_thread_associated dbg (fun () -> Sysfs.is_physical name) () let has_vlan dbg name vlan = (* Identify the vlan is used by kernel which is unknown to XAPI *) - Debug.with_thread_associated dbg (fun () -> - let temp_interfaces = Sysfs.bridge_to_interfaces Network_config.temp_vlan in - List.exists (fun (d, v, p) -> v = vlan && p = name && not (List.mem d temp_interfaces)) (Proc.get_vlans ()) - ) () + Debug.with_thread_associated dbg + (fun () -> + let temp_interfaces = + Sysfs.bridge_to_interfaces Network_config.temp_vlan + in + List.exists + (fun (d, v, p) -> + v = vlan && p = name && not (List.mem d temp_interfaces)) + (Proc.get_vlans ())) + () let bring_up _ dbg ~name = - Debug.with_thread_associated dbg (fun () -> - debug "Bringing up interface %s" name; - Ip.link_set_up name - ) () + Debug.with_thread_associated dbg + (fun () -> + debug "Bringing up interface %s" name ; + Ip.link_set_up name) + () let bring_down dbg name = - Debug.with_thread_associated dbg (fun () -> - debug "Bringing down interface %s" name; - Ip.link_set_down name - ) () + Debug.with_thread_associated dbg + (fun () -> + debug "Bringing down interface %s" name ; + Ip.link_set_down name) + () let set_persistent dbg name value = - Debug.with_thread_associated dbg (fun () -> - debug "Making interface %s %spersistent" name (if value then "" else "non-"); - update_config name {(get_config name) with persistent_i = value} - ) () + Debug.with_thread_associated dbg + (fun () -> + debug "Making interface %s %spersistent" name + (if value then "" else "non-") ; + update_config name {(get_config name) with persistent_i= value}) + () let make_config dbg conservative config = - Debug.with_thread_associated dbg (fun () -> + Debug.with_thread_associated dbg + (fun () -> (* Only attempt to configure interfaces that exist in the system *) let all = get_all dbg () in let config = List.filter (fun (name, _) -> List.mem name all) config in (* Handle conservativeness *) let config = - if conservative then begin + if conservative then ( (* Do not touch non-persistent interfaces *) - debug "Only configuring persistent interfaces"; - List.filter (fun (_name, interface) -> interface.persistent_i) config - end else + debug "Only configuring persistent interfaces" ; + List.filter + (fun (_name, interface) -> interface.persistent_i) + config + ) else config in let config = if need_enic_workaround () then - List.fold_left (fun accu (name, interface) -> - if (Sysfs.is_physical name && Linux_bonding.get_bond_master_of name = None) || Linux_bonding.is_bond_device name then + List.fold_left + (fun accu (name, interface) -> + if + Sysfs.is_physical name + && Linux_bonding.get_bond_master_of name = None + || Linux_bonding.is_bond_device name + then (name, interface) :: (Ip.vlan_name name 0, interface) :: accu else - (name, interface) :: accu - ) [] config + (name, interface) :: accu) + [] config else config in - debug "** Configuring the following interfaces: %s%s" (String.concat ", " (List.map (fun (name, _) -> name) config)) - (if conservative then " (best effort)" else ""); - let exec f = if conservative then (try f () with _ -> ()) else f () in - List.iter (function (name, ({ipv4_conf; ipv4_gateway; ipv6_conf; ipv6_gateway; ipv4_routes; dns=nameservers,domains; mtu; - ethtool_settings; ethtool_offload; _} as c)) -> - update_config name c; - exec (fun () -> - (* We only apply the DNS settings when in static IPv4 mode to avoid conflicts with DHCP mode. - * The `dns` field should really be an option type so that we don't have to derive the intention - * of the caller by looking at other fields. *) - match ipv4_conf with Static4 _ -> set_dns () dbg ~name ~nameservers ~domains | _ -> ()); - exec (fun () -> set_ipv4_conf dbg name ipv4_conf); - exec (fun () -> match ipv4_gateway with None -> () | Some gateway -> - set_ipv4_gateway () dbg ~name ~address:gateway); - (try set_ipv6_conf () dbg ~name ~conf:ipv6_conf with _ -> ()); - (try match ipv6_gateway with None -> () | Some gateway -> - set_ipv6_gateway () dbg ~name ~address:gateway with _ -> ()); - exec (fun () -> set_ipv4_routes () dbg ~name ~routes:ipv4_routes); - exec (fun () -> set_mtu () dbg ~name ~mtu); - exec (fun () -> bring_up () dbg ~name); - exec (fun () -> set_ethtool_settings () dbg ~name ~params:ethtool_settings); - exec (fun () -> set_ethtool_offload () dbg ~name ~params:ethtool_offload) - ) config - ) () + debug "** Configuring the following interfaces: %s%s" + (String.concat ", " (List.map (fun (name, _) -> name) config)) + (if conservative then " (best effort)" else "") ; + let exec f = if conservative then try f () with _ -> () else f () in + List.iter + (function + | ( name + , ( { + ipv4_conf + ; ipv4_gateway + ; ipv6_conf + ; ipv6_gateway + ; ipv4_routes + ; dns= nameservers, domains + ; mtu + ; ethtool_settings + ; ethtool_offload + ; _ + } as c + ) ) -> + update_config name c ; + exec (fun () -> + (* We only apply the DNS settings when in static IPv4 mode to avoid conflicts with DHCP mode. + * The `dns` field should really be an option type so that we don't have to derive the intention + * of the caller by looking at other fields. *) + match ipv4_conf with + | Static4 _ -> + set_dns () dbg ~name ~nameservers ~domains + | _ -> + ()) ; + exec (fun () -> set_ipv4_conf dbg name ipv4_conf) ; + exec (fun () -> + match ipv4_gateway with + | None -> + () + | Some gateway -> + set_ipv4_gateway () dbg ~name ~address:gateway) ; + (try set_ipv6_conf () dbg ~name ~conf:ipv6_conf with _ -> ()) ; + ( try + match ipv6_gateway with + | None -> + () + | Some gateway -> + set_ipv6_gateway () dbg ~name ~address:gateway + with _ -> () + ) ; + exec (fun () -> + set_ipv4_routes () dbg ~name ~routes:ipv4_routes) ; + exec (fun () -> set_mtu () dbg ~name ~mtu) ; + exec (fun () -> bring_up () dbg ~name) ; + exec (fun () -> + set_ethtool_settings () dbg ~name ~params:ethtool_settings) ; + exec (fun () -> + set_ethtool_offload () dbg ~name ~params:ethtool_offload)) + config) + () end module Bridge = struct let add_default = ref [] - let get_config name = - get_config !config.bridge_config default_bridge name + let get_config name = get_config !config.bridge_config default_bridge name let remove_config name = - config := {!config with bridge_config = remove_config !config.bridge_config name} + config := + {!config with bridge_config= remove_config !config.bridge_config name} let update_config name data = - config := {!config with bridge_config = update_config !config.bridge_config name data} + config := + { + !config with + bridge_config= update_config !config.bridge_config name data + } let determine_backend () = try - let backend = String.trim (Xapi_stdext_unix.Unixext.string_of_file !network_conf) in + let backend = + String.trim (Xapi_stdext_unix.Unixext.string_of_file !network_conf) + in match backend with - | "openvswitch" | "vswitch" -> backend_kind := Openvswitch - | "bridge" -> backend_kind := Bridge + | "openvswitch" | "vswitch" -> + backend_kind := Openvswitch + | "bridge" -> + backend_kind := Bridge | backend -> - warn "Network backend unknown (%s). Falling back to Open vSwitch." backend; - backend_kind := Openvswitch + warn "Network backend unknown (%s). Falling back to Open vSwitch." + backend ; + backend_kind := Openvswitch with _ -> - warn "Network-conf file not found. Falling back to Open vSwitch."; + warn "Network-conf file not found. Falling back to Open vSwitch." ; backend_kind := Openvswitch let get_all dbg () = - Debug.with_thread_associated dbg (fun () -> + Debug.with_thread_associated dbg + (fun () -> match !backend_kind with - | Openvswitch -> Ovs.list_bridges () - | Bridge -> Sysfs.get_all_bridges () - ) () + | Openvswitch -> + Ovs.list_bridges () + | Bridge -> + Sysfs.get_all_bridges ()) + () (* Destroy any existing OVS bridge that isn't the "wanted bridge" and has the * given VLAN on it. *) let destroy_existing_vlan_ovs_bridge dbg wanted_bridge (parent, vlan) = let vlan_bridges = - let raw = Ovs.vsctl ["--bare"; "-f"; "table"; "--"; "--columns=name"; "find"; "port"; "fake_bridge=true"; "tag=" ^ (string_of_int vlan)] in - if raw <> "" then Astring.String.cuts ~empty:false ~sep:"\n" (String.trim raw) else [] + let raw = + Ovs.vsctl + [ + "--bare" + ; "-f" + ; "table" + ; "--" + ; "--columns=name" + ; "find" + ; "port" + ; "fake_bridge=true" + ; "tag=" ^ string_of_int vlan + ] + in + if raw <> "" then + Astring.String.cuts ~empty:false ~sep:"\n" (String.trim raw) + else + [] in let existing_bridges = - List.filter ( fun bridge -> + List.filter + (fun bridge -> match Ovs.bridge_to_vlan bridge with - | Some (p, v) -> p = parent && v = vlan - | None -> false - ) vlan_bridges in - List.iter (fun bridge -> - if bridge <> wanted_bridge then begin - debug "Destroying existing bridge %s" bridge; - remove_config bridge; - Interface.set_ipv4_conf dbg bridge None4; + | Some (p, v) -> + p = parent && v = vlan + | None -> + false) + vlan_bridges + in + List.iter + (fun bridge -> + if bridge <> wanted_bridge then ( + debug "Destroying existing bridge %s" bridge ; + remove_config bridge ; + Interface.set_ipv4_conf dbg bridge None4 ; ignore (Ovs.destroy_bridge bridge) - end - ) existing_bridges + )) + existing_bridges (* Destroy any existing Linux bridge that isn't the "wanted bridge" and has the * given VLAN on it. *) let destroy_existing_vlan_linux_bridge dbg wanted_bridge vlan_device = - List.iter (fun bridge -> - if bridge <> wanted_bridge then - let ifaces_on_bridge = Sysfs.bridge_to_interfaces bridge in - if List.mem vlan_device ifaces_on_bridge then begin - debug "Destroying existing bridge %s" bridge; - Interface.bring_down dbg bridge; - remove_config bridge; - Interface.set_ipv4_conf dbg bridge None4; - List.iter (fun dev -> - Brctl.destroy_port bridge dev; - ) ifaces_on_bridge; - ignore (Brctl.destroy_bridge bridge) - end - ) (Sysfs.get_all_bridges ()) + List.iter + (fun bridge -> + if bridge <> wanted_bridge then + let ifaces_on_bridge = Sysfs.bridge_to_interfaces bridge in + if List.mem vlan_device ifaces_on_bridge then ( + debug "Destroying existing bridge %s" bridge ; + Interface.bring_down dbg bridge ; + remove_config bridge ; + Interface.set_ipv4_conf dbg bridge None4 ; + List.iter + (fun dev -> Brctl.destroy_port bridge dev) + ifaces_on_bridge ; + ignore (Brctl.destroy_bridge bridge) + )) + (Sysfs.get_all_bridges ()) let create dbg vlan mac igmp_snooping other_config name = - Debug.with_thread_associated dbg (fun () -> - let other_config = match other_config with - | Some l -> l - | None -> [] in - debug "Creating bridge %s%s" name (match vlan with - | None -> "" - | Some (parent, vlan) -> Printf.sprintf " (VLAN %d on bridge %s)" vlan parent - ); - update_config name {(get_config name) with vlan; bridge_mac=mac; igmp_snooping; other_config}; - begin match !backend_kind with - | Openvswitch -> + Debug.with_thread_associated dbg + (fun () -> + let other_config = match other_config with Some l -> l | None -> [] in + debug "Creating bridge %s%s" name + ( match vlan with + | None -> + "" + | Some (parent, vlan) -> + Printf.sprintf " (VLAN %d on bridge %s)" vlan parent + ) ; + update_config name + { + (get_config name) with + vlan + ; bridge_mac= mac + ; igmp_snooping + ; other_config + } ; + ( match !backend_kind with + | Openvswitch -> let fail_mode = - if not (List.mem_assoc "vswitch-controller-fail-mode" other_config) then + if + not (List.mem_assoc "vswitch-controller-fail-mode" other_config) + then "standalone" else - let mode = List.assoc "vswitch-controller-fail-mode" other_config in - if mode = "secure" || mode = "standalone" then begin - (try if mode = "secure" && Ovs.get_fail_mode name <> "secure" then - add_default := name :: !add_default - with _ -> ()); + let mode = + List.assoc "vswitch-controller-fail-mode" other_config + in + if mode = "secure" || mode = "standalone" then ( + ( try + if mode = "secure" && Ovs.get_fail_mode name <> "secure" + then + add_default := name :: !add_default + with _ -> () + ) ; mode - end else begin - debug "%s isn't a valid setting for other_config:vswitch-controller-fail-mode; \ - defaulting to 'standalone'" mode; + ) else ( + debug + "%s isn't a valid setting for \ + other_config:vswitch-controller-fail-mode; defaulting to \ + 'standalone'" + mode ; "standalone" - end + ) in let vlan_bug_workaround = if List.mem_assoc "vlan-bug-workaround" other_config then @@ -632,277 +833,352 @@ module Bridge = struct in let external_id = if List.mem_assoc "network-uuids" other_config then - Some ("xs-network-uuids", List.assoc "network-uuids" other_config) + Some + ("xs-network-uuids", List.assoc "network-uuids" other_config) else None in let disable_in_band = - if not (List.mem_assoc "vswitch-disable-in-band" other_config) then + if not (List.mem_assoc "vswitch-disable-in-band" other_config) + then Some None else let dib = List.assoc "vswitch-disable-in-band" other_config in if dib = "true" || dib = "false" then Some (Some dib) - else - (debug "%s isn't a valid setting for other_config:vswitch-disable-in-band" dib; - None) + else ( + debug + "%s isn't a valid setting for \ + other_config:vswitch-disable-in-band" + dib ; + None + ) in let old_igmp_snooping = Ovs.get_mcast_snooping_enable ~name in - Xapi_stdext_monadic.Opt.iter (destroy_existing_vlan_ovs_bridge dbg name) vlan; - ignore (Ovs.create_bridge ?mac ~fail_mode ?external_id ?disable_in_band ?igmp_snooping - vlan vlan_bug_workaround name); + Xapi_stdext_monadic.Opt.iter + (destroy_existing_vlan_ovs_bridge dbg name) + vlan ; + ignore + (Ovs.create_bridge ?mac ~fail_mode ?external_id ?disable_in_band + ?igmp_snooping vlan vlan_bug_workaround name) ; if igmp_snooping = Some true && not old_igmp_snooping then Ovs.inject_igmp_query ~name - - | Bridge -> - ignore (Brctl.create_bridge name); - Brctl.set_forwarding_delay name 0; - Sysfs.set_multicast_snooping name false; - Xapi_stdext_monadic.Opt.iter (Ip.set_mac name) mac; + | Bridge -> ( + ignore (Brctl.create_bridge name) ; + Brctl.set_forwarding_delay name 0 ; + Sysfs.set_multicast_snooping name false ; + Xapi_stdext_monadic.Opt.iter (Ip.set_mac name) mac ; match vlan with - | None -> () + | None -> + () | Some (parent, vlan) -> - let bridge_interfaces = Sysfs.bridge_to_interfaces name in - let parent_bridge_interface = List.hd (List.filter (fun n -> - Astring.String.is_prefix ~affix:"eth" n || Astring.String.is_prefix ~affix:"bond" n - ) (Sysfs.bridge_to_interfaces parent)) in - let parent_interface = - if need_enic_workaround () then begin - let n = String.length parent_bridge_interface in - let m = String.sub parent_bridge_interface 0 (n - 2) in - if vlan = 0 then - error "The enic workaround is in effect. Bridge %s is used for VLAN 0 on %s." parent m; - m - end else - parent_bridge_interface - in - let vlan_name = Ip.vlan_name parent_interface vlan in - destroy_existing_vlan_linux_bridge dbg name vlan_name; - (* Check if the VLAN is already in use by something else *) - List.iter (fun (device, vlan', parent') -> - (* A device for the same VLAN (parent + tag), but with a different - * device name or not on the requested bridge is bad. *) - if parent' = parent && vlan' = vlan && - (device <> vlan_name || not (List.mem device bridge_interfaces)) then - raise (Network_error (Vlan_in_use (parent, vlan))) - ) (Proc.get_vlans ()); - (* Robustness enhancement: ensure there are no other VLANs in the bridge *) - let current_interfaces = List.filter (fun n -> - Astring.String.is_prefix ~affix:"eth" n || Astring.String.is_prefix ~affix:"bond" n - ) bridge_interfaces in - debug "Removing these non-VIF interfaces found on the bridge: %s" - (String.concat ", " current_interfaces); - List.iter (fun interface -> - Brctl.destroy_port name interface; - Interface.bring_down dbg interface - ) current_interfaces; - (* Now create the new VLAN device and add it to the bridge *) - Ip.create_vlan parent_interface vlan; - Interface.bring_up () dbg ~name:vlan_name; - Brctl.create_port name vlan_name - end; - Interface.bring_up () dbg ~name - ) () + let bridge_interfaces = Sysfs.bridge_to_interfaces name in + let parent_bridge_interface = + List.hd + (List.filter + (fun n -> + Astring.String.is_prefix ~affix:"eth" n + || Astring.String.is_prefix ~affix:"bond" n) + (Sysfs.bridge_to_interfaces parent)) + in + let parent_interface = + if need_enic_workaround () then ( + let n = String.length parent_bridge_interface in + let m = String.sub parent_bridge_interface 0 (n - 2) in + if vlan = 0 then + error + "The enic workaround is in effect. Bridge %s is used \ + for VLAN 0 on %s." + parent m ; + m + ) else + parent_bridge_interface + in + let vlan_name = Ip.vlan_name parent_interface vlan in + destroy_existing_vlan_linux_bridge dbg name vlan_name ; + (* Check if the VLAN is already in use by something else *) + List.iter + (fun (device, vlan', parent') -> + (* A device for the same VLAN (parent + tag), but with a different + * device name or not on the requested bridge is bad. *) + if + parent' = parent + && vlan' = vlan + && (device <> vlan_name + || not (List.mem device bridge_interfaces) + ) + then + raise (Network_error (Vlan_in_use (parent, vlan)))) + (Proc.get_vlans ()) ; + (* Robustness enhancement: ensure there are no other VLANs in the bridge *) + let current_interfaces = + List.filter + (fun n -> + Astring.String.is_prefix ~affix:"eth" n + || Astring.String.is_prefix ~affix:"bond" n) + bridge_interfaces + in + debug + "Removing these non-VIF interfaces found on the bridge: %s" + (String.concat ", " current_interfaces) ; + List.iter + (fun interface -> + Brctl.destroy_port name interface ; + Interface.bring_down dbg interface) + current_interfaces ; + (* Now create the new VLAN device and add it to the bridge *) + Ip.create_vlan parent_interface vlan ; + Interface.bring_up () dbg ~name:vlan_name ; + Brctl.create_port name vlan_name + ) + ) ; + Interface.bring_up () dbg ~name) + () let destroy dbg force name = - Debug.with_thread_associated dbg (fun () -> - Interface.bring_down dbg name; + Debug.with_thread_associated dbg + (fun () -> + Interface.bring_down dbg name ; match !backend_kind with | Openvswitch -> - let vlans_on_this_parent = Ovs.get_vlans name in - if vlans_on_this_parent = [] || force then begin - debug "Destroying bridge %s" name; - remove_config name; - let interfaces = (Ovs.bridge_to_interfaces name) @ vlans_on_this_parent in - List.iter (fun dev -> - Interface.set_ipv4_conf dbg dev None4; - Interface.bring_down dbg dev - ) interfaces; - Interface.set_ipv4_conf dbg name None4; - ignore (Ovs.destroy_bridge name) - end else - debug "Not destroying bridge %s, because it has VLANs on top" name + let vlans_on_this_parent = Ovs.get_vlans name in + if vlans_on_this_parent = [] || force then ( + debug "Destroying bridge %s" name ; + remove_config name ; + let interfaces = + Ovs.bridge_to_interfaces name @ vlans_on_this_parent + in + List.iter + (fun dev -> + Interface.set_ipv4_conf dbg dev None4 ; + Interface.bring_down dbg dev) + interfaces ; + Interface.set_ipv4_conf dbg name None4 ; + ignore (Ovs.destroy_bridge name) + ) else + debug "Not destroying bridge %s, because it has VLANs on top" name | Bridge -> - let ifs = Sysfs.bridge_to_interfaces name in - let vlans_on_this_parent = - let interfaces = List.filter (fun n -> - Astring.String.is_prefix ~affix:"eth" n || Astring.String.is_prefix ~affix:"bond" n - ) ifs in - match interfaces with - | [] -> [] - | interface :: _ -> - List.filter (Astring.String.is_prefix ~affix:(interface ^ ".")) (Sysfs.list ()) - in - if vlans_on_this_parent = [] || force then begin - debug "Destroying bridge %s" name; - remove_config name; - List.iter (fun dev -> - Interface.set_ipv4_conf dbg dev None4; - Brctl.destroy_port name dev; - Interface.bring_down dbg dev; - if Linux_bonding.is_bond_device dev then - Linux_bonding.remove_bond_master dev; - if (Astring.String.is_prefix ~affix:"eth" dev || Astring.String.is_prefix ~affix:"bond" dev) && String.contains dev '.' then begin - ignore (Ip.destroy_vlan dev); - let n = String.length dev in - if String.sub dev (n - 2) 2 = ".0" && need_enic_workaround () then - let vlan_base = String.sub dev 0 (n - 2) in - if Linux_bonding.is_bond_device vlan_base then - Linux_bonding.remove_bond_master (String.sub dev 0 (n - 2)) - end; - ) ifs; - Interface.set_ipv4_conf dbg name None4; - ignore (Brctl.destroy_bridge name) - end else - debug "Not destroying bridge %s, because it has VLANs on top" name - ) () + let ifs = Sysfs.bridge_to_interfaces name in + let vlans_on_this_parent = + let interfaces = + List.filter + (fun n -> + Astring.String.is_prefix ~affix:"eth" n + || Astring.String.is_prefix ~affix:"bond" n) + ifs + in + match interfaces with + | [] -> + [] + | interface :: _ -> + List.filter + (Astring.String.is_prefix ~affix:(interface ^ ".")) + (Sysfs.list ()) + in + if vlans_on_this_parent = [] || force then ( + debug "Destroying bridge %s" name ; + remove_config name ; + List.iter + (fun dev -> + Interface.set_ipv4_conf dbg dev None4 ; + Brctl.destroy_port name dev ; + Interface.bring_down dbg dev ; + if Linux_bonding.is_bond_device dev then + Linux_bonding.remove_bond_master dev ; + if + (Astring.String.is_prefix ~affix:"eth" dev + || Astring.String.is_prefix ~affix:"bond" dev + ) + && String.contains dev '.' + then ( + ignore (Ip.destroy_vlan dev) ; + let n = String.length dev in + if + String.sub dev (n - 2) 2 = ".0" && need_enic_workaround () + then + let vlan_base = String.sub dev 0 (n - 2) in + if Linux_bonding.is_bond_device vlan_base then + Linux_bonding.remove_bond_master + (String.sub dev 0 (n - 2)) + )) + ifs ; + Interface.set_ipv4_conf dbg name None4 ; + ignore (Brctl.destroy_bridge name) + ) else + debug "Not destroying bridge %s, because it has VLANs on top" name) + () let get_kind dbg () = - Debug.with_thread_associated dbg (fun () -> - !backend_kind - ) () + Debug.with_thread_associated dbg (fun () -> !backend_kind) () let get_all_ports dbg from_cache = - Debug.with_thread_associated dbg (fun () -> + Debug.with_thread_associated dbg + (fun () -> if from_cache then - let ports = List.concat (List.map (fun (_, {ports;_}) -> ports) !config.bridge_config) in - List.map (fun (port, {interfaces;_}) -> port, interfaces) ports + let ports = + List.concat + (List.map (fun (_, {ports; _}) -> ports) !config.bridge_config) + in + List.map (fun (port, {interfaces; _}) -> (port, interfaces)) ports else match !backend_kind with - | Openvswitch -> List.concat (List.map Ovs.bridge_to_ports (Ovs.list_bridges ())) - | Bridge -> raise (Network_error Not_implemented) - ) () + | Openvswitch -> + List.concat (List.map Ovs.bridge_to_ports (Ovs.list_bridges ())) + | Bridge -> + raise (Network_error Not_implemented)) + () let get_all_bonds dbg from_cache = - Debug.with_thread_associated dbg (fun () -> + Debug.with_thread_associated dbg + (fun () -> if from_cache then - let ports = List.concat (List.map (fun (_, {ports;_}) -> ports) !config.bridge_config) in - let names = List.map (fun (port, {interfaces;_}) -> port, interfaces) ports in + let ports = + List.concat + (List.map (fun (_, {ports; _}) -> ports) !config.bridge_config) + in + let names = + List.map (fun (port, {interfaces; _}) -> (port, interfaces)) ports + in List.filter (fun (_, ifs) -> List.length ifs > 1) names else match !backend_kind with - | Openvswitch -> List.concat (List.map Ovs.bridge_to_ports (Ovs.list_bridges ())) - | Bridge -> raise (Network_error Not_implemented) - ) () + | Openvswitch -> + List.concat (List.map Ovs.bridge_to_ports (Ovs.list_bridges ())) + | Bridge -> + raise (Network_error Not_implemented)) + () - type bond_link_info = { - slave: iface; - up: bool; - active: bool; - } + type bond_link_info = {slave: iface; up: bool; active: bool} let get_bond_link_info _ dbg ~name = - Debug.with_thread_associated dbg (fun () -> + Debug.with_thread_associated dbg + (fun () -> match !backend_kind with | Openvswitch -> - let slaves, active_slave = Ovs.get_bond_link_status name in - let mode = Ovs.get_bond_mode name in - List.map (fun (slave, up) -> - let active = - let ab = mode = Some "active-backup" in - ab && (active_slave = Some slave) || - (not ab) && up - in - {slave; up; active} - ) slaves + let slaves, active_slave = Ovs.get_bond_link_status name in + let mode = Ovs.get_bond_mode name in + List.map + (fun (slave, up) -> + let active = + let ab = mode = Some "active-backup" in + (ab && active_slave = Some slave) || ((not ab) && up) + in + {slave; up; active}) + slaves | Bridge -> - let active_slave = Linux_bonding.get_bond_active_slave name in - let slaves = Proc.get_bond_slave_info name "MII Status" in - let bond_props = Linux_bonding.get_bond_properties name in - List.map (fun (slave, status) -> - let up = status = "up" in - let active = - let ab = - List.mem_assoc "mode" bond_props && - Astring.String.is_prefix ~affix:"active-backup" (List.assoc "mode" bond_props) + let active_slave = Linux_bonding.get_bond_active_slave name in + let slaves = Proc.get_bond_slave_info name "MII Status" in + let bond_props = Linux_bonding.get_bond_properties name in + List.map + (fun (slave, status) -> + let up = status = "up" in + let active = + let ab = + List.mem_assoc "mode" bond_props + && Astring.String.is_prefix ~affix:"active-backup" + (List.assoc "mode" bond_props) + in + (ab && active_slave = Some slave) || ((not ab) && up) in - ab && (active_slave = Some slave) || - (not ab) && up - in - {slave; up; active} - ) slaves - ) () + {slave; up; active}) + slaves) + () let add_default_flows _ dbg bridge mac interfaces = - Debug.with_thread_associated dbg (fun () -> + Debug.with_thread_associated dbg + (fun () -> match !backend_kind with - | Openvswitch -> Ovs.add_default_flows bridge mac interfaces - | Bridge -> () - ) () + | Openvswitch -> + Ovs.add_default_flows bridge mac interfaces + | Bridge -> + ()) + () - let add_basic_port dbg bridge name - {interfaces; bond_mac; bond_properties;_} = + let add_basic_port dbg bridge name {interfaces; bond_mac; bond_properties; _} + = match !backend_kind with - | Openvswitch -> - if List.length interfaces = 1 then begin - List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces; - ignore (Ovs.create_port (List.hd interfaces) bridge) - end else begin - if bond_mac = None then - warn "No MAC address specified for the bond"; - ignore (Ovs.create_bond ?mac:bond_mac name interfaces bridge bond_properties); - List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces - end; - if List.mem bridge !add_default then begin - let mac = match bond_mac with - | None -> (try Some (Ip.get_mac name) with _ -> None) - | Some mac -> Some mac - in - match mac with - | Some mac -> - add_default_flows () dbg bridge mac interfaces; - add_default := List.filter ((<>) bridge) !add_default - | None -> - warn "Could not add default flows for port %s on bridge %s because no MAC address was specified" - name bridge - end + | Openvswitch -> ( + if List.length interfaces = 1 then ( + List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces ; + ignore (Ovs.create_port (List.hd interfaces) bridge) + ) else ( + if bond_mac = None then + warn "No MAC address specified for the bond" ; + ignore + (Ovs.create_bond ?mac:bond_mac name interfaces bridge + bond_properties) ; + List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces + ) ; + if List.mem bridge !add_default then + let mac = + match bond_mac with + | None -> ( + try Some (Ip.get_mac name) with _ -> None + ) + | Some mac -> + Some mac + in + match mac with + | Some mac -> + add_default_flows () dbg bridge mac interfaces ; + add_default := List.filter (( <> ) bridge) !add_default + | None -> + warn + "Could not add default flows for port %s on bridge %s because \ + no MAC address was specified" + name bridge + ) | Bridge -> - if List.length interfaces = 1 then - List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces - else begin - Linux_bonding.add_bond_master name; - let bond_properties = - if List.mem_assoc "mode" bond_properties && List.assoc "mode" bond_properties = "lacp" then - Xapi_stdext_std.Listext.List.replace_assoc "mode" "802.3ad" bond_properties - else bond_properties - in - Linux_bonding.set_bond_properties name bond_properties; - Linux_bonding.set_bond_slaves name interfaces; - begin match bond_mac with - | Some mac -> Ip.set_mac name mac - | None -> warn "No MAC address specified for the bond" - end; - Interface.bring_up () dbg ~name - end; - if need_enic_workaround () then begin - debug "Applying enic workaround: adding VLAN0 device to bridge"; - Ip.create_vlan name 0; - let vlan0 = Ip.vlan_name name 0 in - Interface.bring_up () dbg ~name:vlan0; - ignore (Brctl.create_port bridge vlan0) - end else - ignore (Brctl.create_port bridge name) + if List.length interfaces = 1 then + List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces + else ( + Linux_bonding.add_bond_master name ; + let bond_properties = + if + List.mem_assoc "mode" bond_properties + && List.assoc "mode" bond_properties = "lacp" + then + Xapi_stdext_std.Listext.List.replace_assoc "mode" "802.3ad" + bond_properties + else + bond_properties + in + Linux_bonding.set_bond_properties name bond_properties ; + Linux_bonding.set_bond_slaves name interfaces ; + ( match bond_mac with + | Some mac -> + Ip.set_mac name mac + | None -> + warn "No MAC address specified for the bond" + ) ; + Interface.bring_up () dbg ~name + ) ; + if need_enic_workaround () then ( + debug "Applying enic workaround: adding VLAN0 device to bridge" ; + Ip.create_vlan name 0 ; + let vlan0 = Ip.vlan_name name 0 in + Interface.bring_up () dbg ~name:vlan0 ; + ignore (Brctl.create_port bridge vlan0) + ) else + ignore (Brctl.create_port bridge name) let add_pvs_proxy_port dbg bridge name _port = match !backend_kind with | Openvswitch -> - ignore (Ovs.create_port ~internal:true name bridge); - let real_bridge = Ovs.get_real_bridge bridge in - Ovs.mod_port real_bridge name "no-flood"; - Interface.bring_up () dbg ~name + ignore (Ovs.create_port ~internal:true name bridge) ; + let real_bridge = Ovs.get_real_bridge bridge in + Ovs.mod_port real_bridge name "no-flood" ; + Interface.bring_up () dbg ~name | Bridge -> - raise (Network_error Not_implemented) + raise (Network_error Not_implemented) let add_port dbg bond_mac bridge name interfaces bond_properties kind = - Debug.with_thread_associated dbg (fun () -> - let bond_properties = match bond_properties with - | Some l -> l - | None -> [] - in - let kind = match kind with - | Some v -> v - | None -> Basic_port + Debug.with_thread_associated dbg + (fun () -> + let bond_properties = + match bond_properties with Some l -> l | None -> [] in + let kind = match kind with Some v -> v | None -> Basic_port in let config = get_config bridge in let ports = if List.mem_assoc name config.ports then @@ -912,115 +1188,155 @@ module Bridge = struct in let port = {interfaces; bond_mac; bond_properties; kind} in let ports = (name, port) :: ports in - update_config bridge {config with ports}; + update_config bridge {config with ports} ; debug "Adding %s port %s to bridge %s with interface(s) %s%s" - (string_of_port_kind kind) - name bridge + (string_of_port_kind kind) name bridge (String.concat ", " interfaces) - (match bond_mac with Some mac -> " and MAC " ^ mac | None -> ""); + (match bond_mac with Some mac -> " and MAC " ^ mac | None -> "") ; match kind with - | Basic_port -> add_basic_port dbg bridge name port - | PVS_proxy -> add_pvs_proxy_port dbg bridge name port - ) () + | Basic_port -> + add_basic_port dbg bridge name port + | PVS_proxy -> + add_pvs_proxy_port dbg bridge name port) + () let remove_port dbg bridge name = - Debug.with_thread_associated dbg (fun () -> - debug "Removing port %s from bridge %s" name bridge; + Debug.with_thread_associated dbg + (fun () -> + debug "Removing port %s from bridge %s" name bridge ; let config = get_config bridge in - if List.mem_assoc name config.ports then begin - let ports = List.remove_assoc name config.ports in - update_config bridge {config with ports} - end; + ( if List.mem_assoc name config.ports then + let ports = List.remove_assoc name config.ports in + update_config bridge {config with ports} + ) ; match !backend_kind with | Openvswitch -> - ignore (Ovs.destroy_port name) + ignore (Ovs.destroy_port name) | Bridge -> - ignore (Brctl.destroy_port bridge name) - ) () + ignore (Brctl.destroy_port bridge name)) + () let get_interfaces dbg name = - Debug.with_thread_associated dbg (fun () -> + Debug.with_thread_associated dbg + (fun () -> match !backend_kind with | Openvswitch -> - Ovs.bridge_to_interfaces name + Ovs.bridge_to_interfaces name | Bridge -> - Sysfs.bridge_to_interfaces name - ) () + Sysfs.bridge_to_interfaces name) + () let get_physical_interfaces dbg name = - Debug.with_thread_associated dbg (fun () -> + Debug.with_thread_associated dbg + (fun () -> match !backend_kind with | Openvswitch -> - Ovs.get_real_bridge name - |> Ovs.bridge_to_interfaces - |> List.filter (Sysfs.is_physical) - + Ovs.get_real_bridge name + |> Ovs.bridge_to_interfaces + |> List.filter Sysfs.is_physical | Bridge -> - let ifaces = Sysfs.bridge_to_interfaces name in - let vlan_ifaces = List.filter (fun (bridge, _, _) -> List.mem bridge ifaces) (Proc.get_vlans ()) in - let bond_ifaces = List.filter (fun iface -> Linux_bonding.is_bond_device iface) ifaces in - let physical_ifaces = List.filter (fun iface -> Sysfs.is_physical iface) ifaces in - if vlan_ifaces <> [] then - let _, _, parent = List.hd vlan_ifaces in - if Linux_bonding.is_bond_device parent then - Linux_bonding.get_bond_slaves parent + let ifaces = Sysfs.bridge_to_interfaces name in + let vlan_ifaces = + List.filter + (fun (bridge, _, _) -> List.mem bridge ifaces) + (Proc.get_vlans ()) + in + let bond_ifaces = + List.filter + (fun iface -> Linux_bonding.is_bond_device iface) + ifaces + in + let physical_ifaces = + List.filter (fun iface -> Sysfs.is_physical iface) ifaces + in + if vlan_ifaces <> [] then + let _, _, parent = List.hd vlan_ifaces in + if Linux_bonding.is_bond_device parent then + Linux_bonding.get_bond_slaves parent + else + [parent] + else if bond_ifaces <> [] then + Linux_bonding.get_bond_slaves (List.hd bond_ifaces) else - [parent] - else if bond_ifaces <> [] then - Linux_bonding.get_bond_slaves (List.hd bond_ifaces) - else - physical_ifaces - ) () + physical_ifaces) + () let set_persistent dbg name value = - Debug.with_thread_associated dbg (fun () -> - debug "Making bridge %s %spersistent" name (if value then "" else "non-"); - update_config name {(get_config name) with persistent_b = value} - ) () + Debug.with_thread_associated dbg + (fun () -> + debug "Making bridge %s %spersistent" name (if value then "" else "non-") ; + update_config name {(get_config name) with persistent_b= value}) + () let make_config dbg conservative config = - Debug.with_thread_associated dbg (fun () -> - let vlans_go_last (_, {vlan=vlan_of_a;_}) (_, {vlan=vlan_of_b;_}) = - if vlan_of_a = None && vlan_of_b = None then 0 - else if vlan_of_a <> None && vlan_of_b = None then 1 - else if vlan_of_a = None && vlan_of_b <> None then -1 - else 0 + Debug.with_thread_associated dbg + (fun () -> + let vlans_go_last (_, {vlan= vlan_of_a; _}) (_, {vlan= vlan_of_b; _}) = + if vlan_of_a = None && vlan_of_b = None then + 0 + else if vlan_of_a <> None && vlan_of_b = None then + 1 + else if vlan_of_a = None && vlan_of_b <> None then + -1 + else + 0 in let config = - if conservative then begin - let persistent_config = List.filter (fun (_name, bridge) -> bridge.persistent_b) config in + if conservative then ( + let persistent_config = + List.filter (fun (_name, bridge) -> bridge.persistent_b) config + in debug "Ensuring the following persistent bridges are up: %s" - (String.concat ", " (List.map (fun (name, _) -> name) persistent_config)); - let vlan_parents = Xapi_stdext_std.Listext.List.filter_map (function - | (_, {vlan=Some (parent, _);_}) -> - if not (List.mem_assoc parent persistent_config) then - Some (parent, List.assoc parent config) - else - None - | _ -> None) persistent_config in - debug "Additionally ensuring the following VLAN parent bridges are up: %s" - (String.concat ", " (List.map (fun (name, _) -> name) vlan_parents)); + (String.concat ", " + (List.map (fun (name, _) -> name) persistent_config)) ; + let vlan_parents = + Xapi_stdext_std.Listext.List.filter_map + (function + | _, {vlan= Some (parent, _); _} -> + if not (List.mem_assoc parent persistent_config) then + Some (parent, List.assoc parent config) + else + None + | _ -> + None) + persistent_config + in + debug + "Additionally ensuring the following VLAN parent bridges are up: \ + %s" + (String.concat ", " + (List.map (fun (name, _) -> name) vlan_parents)) ; let config = vlan_parents @ persistent_config in (* Do not try to recreate bridges that already exist *) let current = get_all dbg () in - List.filter (function (name, _) -> not (List.mem name current)) config - end else + List.filter + (function name, _ -> not (List.mem name current)) + config + ) else config in let config = List.sort vlans_go_last config in - let exec f = if conservative then (try f () with _ -> ()) else f () in + let exec f = if conservative then try f () with _ -> () else f () in debug "** Configuring the following bridges: %s%s" (String.concat ", " (List.map (fun (name, _) -> name) config)) - (if conservative then " (best effort)" else ""); - List.iter (function (bridge_name, ({ports; vlan; bridge_mac; igmp_snooping; other_config; _} as c)) -> - update_config bridge_name c; - exec (fun () -> - create dbg vlan bridge_mac igmp_snooping (Some other_config) bridge_name; - List.iter (fun (port_name, {interfaces; bond_properties; bond_mac; kind}) -> - add_port dbg bond_mac bridge_name port_name interfaces (Some bond_properties) (Some kind)) ports - ) - ) config - ) () + (if conservative then " (best effort)" else "") ; + List.iter + (function + | ( bridge_name + , ({ports; vlan; bridge_mac; igmp_snooping; other_config; _} as c) + ) -> + update_config bridge_name c ; + exec (fun () -> + create dbg vlan bridge_mac igmp_snooping (Some other_config) + bridge_name ; + List.iter + (fun ( port_name + , {interfaces; bond_properties; bond_mac; kind} ) -> + add_port dbg bond_mac bridge_name port_name interfaces + (Some bond_properties) (Some kind)) + ports)) + config) + () end module PVS_proxy = struct @@ -1029,54 +1345,90 @@ module PVS_proxy = struct let path = ref "/opt/citrix/pvsproxy/socket/pvsproxy" let do_call call = - try - Jsonrpc_client.with_rpc ~path:!path ~call () + try Jsonrpc_client.with_rpc ~path:!path ~call () with e -> - error "Error when calling PVS proxy: %s" (Printexc.to_string e); + error "Error when calling PVS proxy: %s" (Printexc.to_string e) ; raise (Network_error PVS_proxy_connection_error) let configure_site _dbg config = - debug "Configuring PVS proxy for site %s" config.site_uuid; - let call = {Rpc.name = "configure_site"; params = [Rpcmarshal.marshal t.ty config]} in + debug "Configuring PVS proxy for site %s" config.site_uuid ; + let call = + {Rpc.name= "configure_site"; params= [Rpcmarshal.marshal t.ty config]} + in let _ = do_call call in () let remove_site _dbg uuid = - debug "Removing PVS proxy for site %s" uuid; - let call = Rpc.{name = "remove_site"; params = [Dict ["site_uuid", Rpcmarshal.marshal Rpc.Types.string.ty uuid]]} in + debug "Removing PVS proxy for site %s" uuid ; + let call = + Rpc. + { + name= "remove_site" + ; params= + [Dict [("site_uuid", Rpcmarshal.marshal Rpc.Types.string.ty uuid)]] + } + in let _ = do_call call in () end let on_startup () = let dbg = "startup" in - Debug.with_thread_associated dbg (fun () -> - Bridge.determine_backend (); + Debug.with_thread_associated dbg + (fun () -> + Bridge.determine_backend () ; let remove_centos_config () = (* Remove DNSDEV and GATEWAYDEV from Centos networking file, because the interfere * with this daemon. *) try - let file = String.trim (Xapi_stdext_unix.Unixext.string_of_file "/etc/sysconfig/network") in + let file = + String.trim + (Xapi_stdext_unix.Unixext.string_of_file "/etc/sysconfig/network") + in let args = Astring.String.cuts ~empty:false ~sep:"\n" file in - let args = List.map (fun s -> match (Astring.String.cuts ~sep:"=" s) with k :: [v] -> k, v | _ -> "", "") args in - let args = List.filter (fun (k, _) -> k <> "DNSDEV" && k <> "GATEWAYDEV") args in - let s = String.concat "\n" (List.map (fun (k, v) -> k ^ "=" ^ v) args) ^ "\n" in - Xapi_stdext_unix.Unixext.write_string_to_file "/etc/sysconfig/network" s + let args = + List.map + (fun s -> + match Astring.String.cuts ~sep:"=" s with + | [k; v] -> + (k, v) + | _ -> + ("", "")) + args + in + let args = + List.filter (fun (k, _) -> k <> "DNSDEV" && k <> "GATEWAYDEV") args + in + let s = + String.concat "\n" (List.map (fun (k, v) -> k ^ "=" ^ v) args) + ^ "\n" + in + Xapi_stdext_unix.Unixext.write_string_to_file "/etc/sysconfig/network" + s with _ -> () in try (* the following is best-effort *) - read_config (); - remove_centos_config (); + read_config () ; + remove_centos_config () ; if !backend_kind = Openvswitch then - Ovs.set_max_idle 5000; - Bridge.make_config dbg true !config.bridge_config; - Interface.make_config dbg true !config.interface_config; + Ovs.set_max_idle 5000 ; + Bridge.make_config dbg true !config.bridge_config ; + Interface.make_config dbg true !config.interface_config ; (* If there is still a network.dbcache file, move it out of the way. *) - if (try Unix.access (Filename.concat "/var/lib/xcp" "network.dbcache") [Unix.F_OK]; true with _ -> false) then - Unix.rename (Filename.concat "/var/lib/xcp" "network.dbcache") (Filename.concat "/var/lib/xcp" "network.dbcache.bak"); + if + try + Unix.access + (Filename.concat "/var/lib/xcp" "network.dbcache") + [Unix.F_OK] ; + true + with _ -> false + then + Unix.rename + (Filename.concat "/var/lib/xcp" "network.dbcache") + (Filename.concat "/var/lib/xcp" "network.dbcache.bak") with e -> debug "Error while configuring networks on startup: %s\n%s" - (Printexc.to_string e) (Printexc.get_backtrace ()) - ) () - + (Printexc.to_string e) + (Printexc.get_backtrace ())) + () diff --git a/networkd/networkd.ml b/networkd/networkd.ml index 13a2a64ef..8caa327e6 100644 --- a/networkd/networkd.ml +++ b/networkd/networkd.ml @@ -12,157 +12,216 @@ * GNU Lesser General Public License for more details. *) -module D = Debug.Make(struct let name = "networkd" end) - -let resources = [ - { Xcp_service.name = "network-conf"; - description = "used to select the network backend"; - essential = true; - path = Network_server.network_conf; - perms = [ Unix.R_OK ]; - }; - { Xcp_service.name = "brctl"; - description = "used to set up bridges"; - essential = true; - path = Network_utils.brctl; - perms = [ Unix.X_OK ]; - }; - { Xcp_service.name = "ethtool"; - description = "used to configure network interfaces"; - essential = true; - path = Network_utils.ethtool; - perms = [ Unix.X_OK ]; - }; - { Xcp_service.name = "fcoedriver"; - description = "used to identify fcoe interfaces"; - essential = false; - path = Network_utils.fcoedriver; - perms = [ Unix.X_OK ]; - }; - { Xcp_service.name = "inject-igmp-query-script"; - description = "used to inject an IGMP query message for a bridge"; - essential = false; - path = Network_utils.inject_igmp_query_script; - perms = [ Unix.X_OK ]; - } -] +module D = Debug.Make (struct let name = "networkd" end) + +let resources = + [ + { + Xcp_service.name= "network-conf" + ; description= "used to select the network backend" + ; essential= true + ; path= Network_server.network_conf + ; perms= [Unix.R_OK] + } + ; { + Xcp_service.name= "brctl" + ; description= "used to set up bridges" + ; essential= true + ; path= Network_utils.brctl + ; perms= [Unix.X_OK] + } + ; { + Xcp_service.name= "ethtool" + ; description= "used to configure network interfaces" + ; essential= true + ; path= Network_utils.ethtool + ; perms= [Unix.X_OK] + } + ; { + Xcp_service.name= "fcoedriver" + ; description= "used to identify fcoe interfaces" + ; essential= false + ; path= Network_utils.fcoedriver + ; perms= [Unix.X_OK] + } + ; { + Xcp_service.name= "inject-igmp-query-script" + ; description= "used to inject an IGMP query message for a bridge" + ; essential= false + ; path= Network_utils.inject_igmp_query_script + ; perms= [Unix.X_OK] + } + ] -let options = [ - "monitor_whitelist", Arg.String (fun x -> Network_monitor_thread.monitor_whitelist := Astring.String.cuts ~empty:false ~sep:"," x), (fun () -> String.concat "," !Network_monitor_thread.monitor_whitelist), "List of prefixes of interface names that are to be monitored"; - "mac-table-size", Arg.Set_int Network_utils.mac_table_size, (fun () -> string_of_int !Network_utils.mac_table_size), "Default value for the mac-table-size openvswitch parameter (see ovs-vswitchd.conf.db.5)"; - "pvs-proxy-socket", Arg.Set_string Network_server.PVS_proxy.path, (fun () -> !Network_server.PVS_proxy.path), "Path to the Unix domain socket for the PVS-proxy daemon"; - "igmp-query-maxresp-time", Arg.Set_string Network_utils.igmp_query_maxresp_time, (fun () -> !Network_utils.igmp_query_maxresp_time), "Maximum Response Time in IGMP Query message to send"; - "enable-ipv6-mcast-snooping", Arg.Bool (fun x -> Network_utils.enable_ipv6_mcast_snooping := x), (fun () -> string_of_bool !Network_utils.enable_ipv6_mcast_snooping), "IPv6 multicast snooping toggle"; - "mcast-snooping-disable-flood-unregistered", Arg.Bool (fun x -> Network_utils.mcast_snooping_disable_flood_unregistered := x), (fun () -> string_of_bool !Network_utils.mcast_snooping_disable_flood_unregistered), "Set OVS bridge configuration mcast-snooping-disable-flood-unregistered as 'true' or 'false'"; - "uname-cmd-path", Arg.Set_string Network_utils.uname, (fun () -> !Network_utils.uname), "Path to the Unix command uname"; - "dracut-cmd-path", Arg.Set_string Network_utils.dracut, (fun () -> !Network_utils.dracut), "Path to the Unix command dracut"; - "dracut-timeout", Arg.Set_float Network_utils.dracut_timeout, (fun () -> string_of_float !Network_utils.dracut_timeout), "Default value for the dracut command timeout"; - "modinfo-cmd-path", Arg.Set_string Network_utils.modinfo, (fun () -> !Network_utils.modinfo), "Path to the Unix command modinfo"; - "json-rpc-max-len", Arg.Set_int Jsonrpc_client.json_rpc_max_len, (fun () -> string_of_int !Jsonrpc_client.json_rpc_max_len), "Maximum buffer size for Json RPC response"; - "json-rpc-read-timeout", Arg.Int (fun x -> Jsonrpc_client.json_rpc_read_timeout := Int64.(mul 1000000L (of_int x))), (fun () -> Int64.(to_string (div !Jsonrpc_client.json_rpc_read_timeout 1000000L))), "JSON RPC response read timeout value in ms"; - "json-rpc-write-timeout", Arg.Int (fun x -> Jsonrpc_client.json_rpc_write_timeout := Int64.(mul 1000000L (of_int x))), (fun () -> Int64.(to_string (div !Jsonrpc_client.json_rpc_write_timeout 1000000L))), "JSON RPC write timeout value in ms"; -] +let options = + [ + ( "monitor_whitelist" + , Arg.String + (fun x -> + Network_monitor_thread.monitor_whitelist := + Astring.String.cuts ~empty:false ~sep:"," x) + , (fun () -> String.concat "," !Network_monitor_thread.monitor_whitelist) + , "List of prefixes of interface names that are to be monitored" ) + ; ( "mac-table-size" + , Arg.Set_int Network_utils.mac_table_size + , (fun () -> string_of_int !Network_utils.mac_table_size) + , "Default value for the mac-table-size openvswitch parameter (see \ + ovs-vswitchd.conf.db.5)" ) + ; ( "pvs-proxy-socket" + , Arg.Set_string Network_server.PVS_proxy.path + , (fun () -> !Network_server.PVS_proxy.path) + , "Path to the Unix domain socket for the PVS-proxy daemon" ) + ; ( "igmp-query-maxresp-time" + , Arg.Set_string Network_utils.igmp_query_maxresp_time + , (fun () -> !Network_utils.igmp_query_maxresp_time) + , "Maximum Response Time in IGMP Query message to send" ) + ; ( "enable-ipv6-mcast-snooping" + , Arg.Bool (fun x -> Network_utils.enable_ipv6_mcast_snooping := x) + , (fun () -> string_of_bool !Network_utils.enable_ipv6_mcast_snooping) + , "IPv6 multicast snooping toggle" ) + ; ( "mcast-snooping-disable-flood-unregistered" + , Arg.Bool + (fun x -> Network_utils.mcast_snooping_disable_flood_unregistered := x) + , (fun () -> + string_of_bool !Network_utils.mcast_snooping_disable_flood_unregistered) + , "Set OVS bridge configuration mcast-snooping-disable-flood-unregistered \ + as 'true' or 'false'" ) + ; ( "uname-cmd-path" + , Arg.Set_string Network_utils.uname + , (fun () -> !Network_utils.uname) + , "Path to the Unix command uname" ) + ; ( "dracut-cmd-path" + , Arg.Set_string Network_utils.dracut + , (fun () -> !Network_utils.dracut) + , "Path to the Unix command dracut" ) + ; ( "dracut-timeout" + , Arg.Set_float Network_utils.dracut_timeout + , (fun () -> string_of_float !Network_utils.dracut_timeout) + , "Default value for the dracut command timeout" ) + ; ( "modinfo-cmd-path" + , Arg.Set_string Network_utils.modinfo + , (fun () -> !Network_utils.modinfo) + , "Path to the Unix command modinfo" ) + ; ( "json-rpc-max-len" + , Arg.Set_int Jsonrpc_client.json_rpc_max_len + , (fun () -> string_of_int !Jsonrpc_client.json_rpc_max_len) + , "Maximum buffer size for Json RPC response" ) + ; ( "json-rpc-read-timeout" + , Arg.Int + (fun x -> + Jsonrpc_client.json_rpc_read_timeout := + Int64.(mul 1000000L (of_int x))) + , (fun () -> + Int64.(to_string (div !Jsonrpc_client.json_rpc_read_timeout 1000000L))) + , "JSON RPC response read timeout value in ms" ) + ; ( "json-rpc-write-timeout" + , Arg.Int + (fun x -> + Jsonrpc_client.json_rpc_write_timeout := + Int64.(mul 1000000L (of_int x))) + , (fun () -> + Int64.(to_string (div !Jsonrpc_client.json_rpc_write_timeout 1000000L))) + , "JSON RPC write timeout value in ms" ) + ] let start server = - Network_monitor_thread.start (); - Network_server.on_startup (); - let (_: Thread.t) = Thread.create (fun () -> - Xcp_service.serve_forever server - ) () in + Network_monitor_thread.start () ; + Network_server.on_startup () ; + let (_ : Thread.t) = + Thread.create (fun () -> Xcp_service.serve_forever server) () + in () let stop signal = - Network_server.on_shutdown signal; - Network_monitor_thread.stop (); + Network_server.on_shutdown signal ; + Network_monitor_thread.stop () ; exit 0 let handle_shutdown () = - Sys.set_signal Sys.sigterm (Sys.Signal_handle stop); - Sys.set_signal Sys.sigint (Sys.Signal_handle stop); + Sys.set_signal Sys.sigterm (Sys.Signal_handle stop) ; + Sys.set_signal Sys.sigint (Sys.Signal_handle stop) ; Sys.set_signal Sys.sigpipe Sys.Signal_ignore -let doc = String.concat "\n" [ - "This is the xapi toolstack network management daemon."; - ""; - "This service looks after host network configuration, including setting up bridges and/or openvswitch instances, configuring IP addresses etc."; - ] - +let doc = + String.concat "\n" + [ + "This is the xapi toolstack network management daemon." + ; "" + ; "This service looks after host network configuration, including setting \ + up bridges and/or openvswitch instances, configuring IP addresses etc." + ] let bind () = let open Network_server in - S.clear_state clear_state; - S.reset_state reset_state; - S.set_gateway_interface set_gateway_interface; - S.set_dns_interface set_dns_interface; - S.Interface.get_all Interface.get_all; - S.Interface.exists Interface.exists; - S.Interface.get_mac Interface.get_mac; - S.Interface.get_pci_bus_path Interface.get_pci_bus_path; - S.Interface.is_up Interface.is_up; - S.Interface.get_ipv4_addr Interface.get_ipv4_addr; - S.Interface.set_ipv4_conf Interface.set_ipv4_conf; - S.Interface.get_ipv4_gateway Interface.get_ipv4_gateway; - S.Interface.get_ipv6_addr Interface.get_ipv6_addr; - S.Interface.get_dns Interface.get_dns; - S.Interface.get_mtu Interface.get_mtu; - S.Interface.get_capabilities Interface.get_capabilities; - S.Interface.is_connected Interface.is_connected; - S.Interface.is_physical Interface.is_physical; - S.Interface.has_vlan Interface.has_vlan; - S.Interface.bring_down Interface.bring_down; - S.Interface.set_persistent Interface.set_persistent; - S.Interface.make_config Interface.make_config; - S.Bridge.get_all Bridge.get_all; - S.Bridge.create Bridge.create; - S.Bridge.destroy Bridge.destroy; - S.Bridge.get_kind Bridge.get_kind; - S.Bridge.get_all_ports Bridge.get_all_ports; - S.Bridge.get_all_bonds Bridge.get_all_bonds; - S.Bridge.set_persistent Bridge.set_persistent; - S.Bridge.add_port Bridge.add_port; - S.Bridge.remove_port Bridge.remove_port; - S.Bridge.get_interfaces Bridge.get_interfaces; - S.Bridge.get_physical_interfaces Bridge.get_physical_interfaces; - S.Bridge.make_config Bridge.make_config; - S.PVS_proxy.configure_site PVS_proxy.configure_site; - S.PVS_proxy.remove_site PVS_proxy.remove_site; - S.Sriov.enable Sriov.enable; - S.Sriov.disable Sriov.disable; + S.clear_state clear_state ; + S.reset_state reset_state ; + S.set_gateway_interface set_gateway_interface ; + S.set_dns_interface set_dns_interface ; + S.Interface.get_all Interface.get_all ; + S.Interface.exists Interface.exists ; + S.Interface.get_mac Interface.get_mac ; + S.Interface.get_pci_bus_path Interface.get_pci_bus_path ; + S.Interface.is_up Interface.is_up ; + S.Interface.get_ipv4_addr Interface.get_ipv4_addr ; + S.Interface.set_ipv4_conf Interface.set_ipv4_conf ; + S.Interface.get_ipv4_gateway Interface.get_ipv4_gateway ; + S.Interface.get_ipv6_addr Interface.get_ipv6_addr ; + S.Interface.get_dns Interface.get_dns ; + S.Interface.get_mtu Interface.get_mtu ; + S.Interface.get_capabilities Interface.get_capabilities ; + S.Interface.is_connected Interface.is_connected ; + S.Interface.is_physical Interface.is_physical ; + S.Interface.has_vlan Interface.has_vlan ; + S.Interface.bring_down Interface.bring_down ; + S.Interface.set_persistent Interface.set_persistent ; + S.Interface.make_config Interface.make_config ; + S.Bridge.get_all Bridge.get_all ; + S.Bridge.create Bridge.create ; + S.Bridge.destroy Bridge.destroy ; + S.Bridge.get_kind Bridge.get_kind ; + S.Bridge.get_all_ports Bridge.get_all_ports ; + S.Bridge.get_all_bonds Bridge.get_all_bonds ; + S.Bridge.set_persistent Bridge.set_persistent ; + S.Bridge.add_port Bridge.add_port ; + S.Bridge.remove_port Bridge.remove_port ; + S.Bridge.get_interfaces Bridge.get_interfaces ; + S.Bridge.get_physical_interfaces Bridge.get_physical_interfaces ; + S.Bridge.make_config Bridge.make_config ; + S.PVS_proxy.configure_site PVS_proxy.configure_site ; + S.PVS_proxy.remove_site PVS_proxy.remove_site ; + S.Sriov.enable Sriov.enable ; + S.Sriov.disable Sriov.disable ; S.Sriov.make_vf_config Sriov.make_vf_config let _ = - Coverage.init "networkd"; - begin match Xcp_service.configure2 - ~name:Sys.argv.(0) - ~version:Version.version - ~doc ~options ~resources () with - | `Ok () -> () + Coverage.init "networkd" ; + ( match + Xcp_service.configure2 ~name:Sys.argv.(0) ~version:Version.version ~doc + ~options ~resources () + with + | `Ok () -> + () | `Error m -> - Printf.fprintf stderr "%s\n" m; - exit 1 - end; - - bind (); - let server = Xcp_service.make + Printf.fprintf stderr "%s\n" m ; + exit 1 + ) ; + bind () ; + let server = + Xcp_service.make ~path:!Network_interface.default_path ~queue_name:!Network_interface.queue_name ~rpc_fn:(Idl.Exn.server Network_server.S.implementation) - () in - - Xcp_service.maybe_daemonize ~start_fn:(fun () -> - Debug.set_facility Syslog.Local5; - + () + in + Xcp_service.maybe_daemonize + ~start_fn:(fun () -> + Debug.set_facility Syslog.Local5 ; (* We should make the following configurable *) - Debug.disable "http"; - - handle_shutdown (); - Debug.with_thread_associated "main" start server - ) (); - - ignore (Daemon.notify Daemon.State.Ready); - + Debug.disable "http" ; + handle_shutdown () ; + Debug.with_thread_associated "main" start server) + () ; + ignore (Daemon.notify Daemon.State.Ready) ; while true do - Thread.delay 300.; - Network_server.on_timer () + Thread.delay 300. ; Network_server.on_timer () done - diff --git a/networkd_db/networkd_db.ml b/networkd_db/networkd_db.ml index 408efd2d1..629b4cbf0 100644 --- a/networkd_db/networkd_db.ml +++ b/networkd_db/networkd_db.ml @@ -20,88 +20,117 @@ let _ = let bridge = ref "" in let iface = ref "" in let rc = ref 0 in - Arg.parse (Arg.align [ - "-bridge", Arg.Set_string bridge, "Bridge name"; - "-iface", Arg.Set_string iface, "Interface name"; - ]) + Arg.parse + (Arg.align + [ + ("-bridge", Arg.Set_string bridge, "Bridge name") + ; ("-iface", Arg.Set_string iface, "Interface name") + ]) (fun _ -> failwith "Invalid argument") - (Printf.sprintf "Usage: %s [-bridge | -iface ]" name); - + (Printf.sprintf "Usage: %s [-bridge | -iface ]" name) ; try - Coverage.init "network_db"; + Coverage.init "network_db" ; let config = Network_config.read_config () in if !bridge <> "" then - if List.mem_assoc !bridge config.bridge_config then begin + if List.mem_assoc !bridge config.bridge_config then ( let bridge_config = List.assoc !bridge config.bridge_config in - let ifaces = List.flatten (List.map (fun (_, port) -> port.interfaces) bridge_config.ports) in - Printf.printf "interfaces=%s\n" (String.concat "," ifaces); - begin match bridge_config.vlan with - | None -> () - | Some (parent, id) -> Printf.printf "vlan=%d\nparent=%s\n" id parent - end - end else begin - rc := 1; - Printf.fprintf stderr "Could not find bridge %s\n" !bridge; - end; + let ifaces = + List.flatten + (List.map (fun (_, port) -> port.interfaces) bridge_config.ports) + in + Printf.printf "interfaces=%s\n" (String.concat "," ifaces) ; + match bridge_config.vlan with + | None -> + () + | Some (parent, id) -> + Printf.printf "vlan=%d\nparent=%s\n" id parent + ) else ( + rc := 1 ; + Printf.fprintf stderr "Could not find bridge %s\n" !bridge + ) ; if !iface <> "" then - if List.mem_assoc !iface config.interface_config then begin + if List.mem_assoc !iface config.interface_config then let interface_config = List.assoc !iface config.interface_config in - let datav4 = match interface_config.ipv4_conf with + let datav4 = + match interface_config.ipv4_conf with | DHCP4 -> - ["mode", "dhcp"] + [("mode", "dhcp")] | Static4 conf -> - let mode = ["mode", "static"] in - let addrs = - List.flatten (List.map (fun (ip, plen) -> - ["ipaddr", Unix.string_of_inet_addr ip; "netmask", prefixlen_to_netmask plen] - ) conf) - in - let gateway = match interface_config.ipv4_gateway with - | None -> [] - | Some addr -> ["gateway", Unix.string_of_inet_addr addr] - in - let dns = - let dns' = List.map Unix.string_of_inet_addr (fst interface_config.dns) in - if dns' = [] then - [] - else - ["dns", String.concat "," dns'] - in - let domains = - let domains' = snd interface_config.dns in - if domains' = [] then - [] - else - ["domain", String.concat "," domains'] - in - mode @ addrs @ gateway @ dns @ domains - | None4 -> [] + let mode = [("mode", "static")] in + let addrs = + List.flatten + (List.map + (fun (ip, plen) -> + [ + ("ipaddr", Unix.string_of_inet_addr ip) + ; ("netmask", prefixlen_to_netmask plen) + ]) + conf) + in + let gateway = + match interface_config.ipv4_gateway with + | None -> + [] + | Some addr -> + [("gateway", Unix.string_of_inet_addr addr)] + in + let dns = + let dns' = + List.map Unix.string_of_inet_addr (fst interface_config.dns) + in + if dns' = [] then + [] + else + [("dns", String.concat "," dns')] + in + let domains = + let domains' = snd interface_config.dns in + if domains' = [] then + [] + else + [("domain", String.concat "," domains')] + in + mode @ addrs @ gateway @ dns @ domains + | None4 -> + [] in - let datav6 = match interface_config.ipv6_conf with + let datav6 = + match interface_config.ipv6_conf with | DHCP6 -> - ["modev6", "dhcp"] + [("modev6", "dhcp")] | Autoconf6 -> - ["modev6", "autoconf"] + [("modev6", "autoconf")] | Static6 conf -> - let mode = ["modev6", "static"] in - let addrs = - List.flatten (List.map (fun (ip, plen) -> - ["ipv6addr", (Unix.string_of_inet_addr ip) ^ "/" ^ (string_of_int plen)] - ) conf) - in - let gateway = match interface_config.ipv6_gateway with - | None -> [] - | Some addr -> ["gatewayv6", Unix.string_of_inet_addr addr] - in - mode @ addrs @ gateway - | None6 | Linklocal6 -> [] + let mode = [("modev6", "static")] in + let addrs = + List.flatten + (List.map + (fun (ip, plen) -> + [ + ( "ipv6addr" + , Unix.string_of_inet_addr ip + ^ "/" + ^ string_of_int plen ) + ]) + conf) + in + let gateway = + match interface_config.ipv6_gateway with + | None -> + [] + | Some addr -> + [("gatewayv6", Unix.string_of_inet_addr addr)] + in + mode @ addrs @ gateway + | None6 | Linklocal6 -> + [] in let data = datav4 @ datav6 in List.iter (fun (k, v) -> Printf.printf "%s=%s\n" k v) data - end else begin - rc := 1; - Printf.fprintf stderr "Could not find interface %s\n" !iface; - end; + else ( + rc := 1 ; + Printf.fprintf stderr "Could not find interface %s\n" !iface + ) with Network_config.Read_error -> - Printf.fprintf stderr "Failed to read %s\n" name; - exit !rc; + Printf.fprintf stderr "Failed to read %s\n" name ; + exit !rc diff --git a/profiling/coverage.ml b/profiling/coverage.ml index 2d0b60a89..a99750d72 100644 --- a/profiling/coverage.ml +++ b/profiling/coverage.ml @@ -1,18 +1,14 @@ - (** This module sets up the env variable for bisect_ppx which describes * where log files are written. *) - (** [init name] sets up coverage profiling for binary [name]. You could * use [Sys.argv.(0)] for [name]. *) let init name = - let (//) = Filename.concat in - let tmpdir = Filename.get_temp_dir_name () in - try - ignore (Sys.getenv "BISECT_FILE") + let ( // ) = Filename.concat in + let tmpdir = Filename.get_temp_dir_name () in + try ignore (Sys.getenv "BISECT_FILE") with Not_found -> Unix.putenv "BISECT_FILE" (tmpdir // Printf.sprintf "bisect-%s-" name) - diff --git a/profiling/coverage.mli b/profiling/coverage.mli index 9b2cc50f8..f50e8efbf 100644 --- a/profiling/coverage.mli +++ b/profiling/coverage.mli @@ -1,7 +1,5 @@ - - (** [init name] sets up coverage profiling for binary [name]. You could * use [Sys.argv.(0) for name *) -val init: string -> unit +val init : string -> unit diff --git a/test/jsonrpc_dummy.ml b/test/jsonrpc_dummy.ml index c5a593638..36fed15cf 100644 --- a/test/jsonrpc_dummy.ml +++ b/test/jsonrpc_dummy.ml @@ -1,14 +1,19 @@ let path = Sys.argv.(1) let _ = - Sys.set_signal Sys.sigint (Sys.Signal_handle (fun _ -> Unix.unlink path; exit 0)); - Unix.establish_server (fun fin fout -> + Sys.set_signal Sys.sigint + (Sys.Signal_handle (fun _ -> Unix.unlink path ; exit 0)) ; + Unix.establish_server + (fun fin fout -> let rec loop () = let json = Jsonrpc_client.input_json_object fin in - Printf.printf "Received: %s\n" json; - let response = Jsonrpc.string_of_response ~version:Jsonrpc.V2 (Rpc.success (Rpc.String "Thanks!")) in - Printf.printf "Response: %s\n" response; + Printf.printf "Received: %s\n" json ; + let response = + Jsonrpc.string_of_response ~version:Jsonrpc.V2 + (Rpc.success (Rpc.String "Thanks!")) + in + Printf.printf "Response: %s\n" response ; output_string fout response in - loop () - ) (Unix.ADDR_UNIX path) + loop ()) + (Unix.ADDR_UNIX path) diff --git a/test/network_test.ml b/test/network_test.ml index 61811d1a8..601fe8055 100644 --- a/test/network_test.ml +++ b/test/network_test.ml @@ -13,8 +13,6 @@ *) let () = - Debug.log_to_stdout (); - Alcotest.run "base_suite" ( - Network_test_lacp_properties.suite @ - Test_jsonrpc_client.tests - ) + Debug.log_to_stdout () ; + Alcotest.run "base_suite" + (Network_test_lacp_properties.suite @ Test_jsonrpc_client.tests) diff --git a/test/network_test_lacp_properties.ml b/test/network_test_lacp_properties.ml index ab53998bb..5330bd4be 100644 --- a/test/network_test_lacp_properties.ml +++ b/test/network_test_lacp_properties.ml @@ -15,41 +15,45 @@ open Network_utils let check_string_list = Alcotest.(check (list string)) -let to_test_string prefix ps = Format.sprintf "%s: %s" prefix (String.concat ";" ps) + +let to_test_string prefix ps = + Format.sprintf "%s: %s" prefix (String.concat ";" ps) let run_bond_prop_test props c_props c_per_iface = - let props, per_iface_props = - Ovs.make_bond_properties "bond_test" props in - check_string_list (to_test_string "c_props" c_props) c_props props; - check_string_list (to_test_string "c_per_iface" c_per_iface) c_per_iface per_iface_props + let props, per_iface_props = Ovs.make_bond_properties "bond_test" props in + check_string_list (to_test_string "c_props" c_props) c_props props ; + check_string_list + (to_test_string "c_per_iface" c_per_iface) + c_per_iface per_iface_props let test_lacp_timeout_prop arg () = - let props = [ "mode", "lacp" ; "lacp-time", arg ; ] + let props = [("mode", "lacp"); ("lacp-time", arg)] and correct_props = - [ "lacp=active"; - "bond_mode=balance-tcp"; - Printf.sprintf "other-config:lacp-time=\"%s\"" arg ] - and correct_iface_props = [ ] in - + [ + "lacp=active" + ; "bond_mode=balance-tcp" + ; Printf.sprintf "other-config:lacp-time=\"%s\"" arg + ] + and correct_iface_props = [] in run_bond_prop_test props correct_props correct_iface_props let test_lacp_aggregation_key arg () = - let props, per_iface_props = Ovs.make_bond_properties "bond_test" - [ "mode", "lacp" ; "lacp-aggregation-key", arg ] - and correct_props = [ - "lacp=active"; - "bond_mode=balance-tcp"; - ] - and correct_iface_props = [ - Printf.sprintf "other-config:lacp-aggregation-key=\"%s\"" arg ; - ] in - - check_string_list "lacp_aggregation_key_correct_props" correct_props props; - check_string_list "lacp_aggregation_key_correct_iface_props" correct_iface_props per_iface_props + let props, per_iface_props = + Ovs.make_bond_properties "bond_test" + [("mode", "lacp"); ("lacp-aggregation-key", arg)] + and correct_props = ["lacp=active"; "bond_mode=balance-tcp"] + and correct_iface_props = + [Printf.sprintf "other-config:lacp-aggregation-key=\"%s\"" arg] + in + check_string_list "lacp_aggregation_key_correct_props" correct_props props ; + check_string_list "lacp_aggregation_key_correct_iface_props" + correct_iface_props per_iface_props module OVS_Cli_test = struct include Ovs.Cli + let vsctl_output = ref [] + let vsctl ?log:_ args = vsctl_output := args ; String.concat " " args @@ -57,52 +61,58 @@ end (* XXX TODO write this test *) let test_lacp_aggregation_key_vsctl arg () = - let module Ovs = Ovs.Make(OVS_Cli_test) in + let module Ovs = Ovs.Make (OVS_Cli_test) in let bond = "bond0" and ifaces = ["eth0"; "eth1"] and bridge = "xapi1" - and props = [ "mode", "lacp" ; "lacp-aggregation-key", arg ] + and props = [("mode", "lacp"); ("lacp-aggregation-key", arg)] (* other-config:lacp-aggregation-key=42 *) - and answer = "other-config:lacp-aggregation-key=" ^ arg - in + and answer = "other-config:lacp-aggregation-key=" ^ arg in Ovs.create_bond bond ifaces bridge props |> ignore ; List.iter print_endline !OVS_Cli_test.vsctl_output ; print_endline answer ; (* todo: pass -> replace with bool *) - Alcotest.(check pass "lacp_aggregation_key is passed to ovs-vsctl command" true - (List.exists - (fun s -> (String.trim s) == answer) - !OVS_Cli_test.vsctl_output)) + Alcotest.( + check pass "lacp_aggregation_key is passed to ovs-vsctl command" true + (List.exists + (fun s -> String.trim s == answer) + !OVS_Cli_test.vsctl_output)) (* Test case for bond_create with default lacp-{time,aggregation-key} settings. This should not call ovs-vsctl with unfinished key=value arguments. So we shouldn't have somthing like "other-config:lacp-aggregation-key= ". *) let test_lacp_defaults_bond_create () = - let module Ovs = Ovs.Make(OVS_Cli_test) in + let module Ovs = Ovs.Make (OVS_Cli_test) in let bond = "bond0" and ifaces = ["eth0"; "eth1"] and bridge = "xapi1" - and default_props = [ - "mode", "lacp"; - "lacp-time", "slow"; - "hashing_algorithm", "tcpudp_ports"; - ] + and default_props = + [ + ("mode", "lacp") + ; ("lacp-time", "slow") + ; ("hashing_algorithm", "tcpudp_ports") + ] in - Ovs.create_bond bond ifaces bridge default_props |> ignore; + Ovs.create_bond bond ifaces bridge default_props |> ignore ; (* should not have any strings which contain lacp-aggregation-key *) (*assert_bool "no default property for lacp_aggregation_key" List.exists (fun s -> String.*) List.iter (fun arg -> - Alcotest.(check bool "key=value argument pairs can't have missing values" true - (let open Astring.String in + Alcotest.( + check bool "key=value argument pairs can't have missing values" true + (let open Astring.String in arg |> trim |> is_suffix ~affix:"=" |> not))) !OVS_Cli_test.vsctl_output -let suite = [ "test_lacp", [ "timeout_prop(slow)", `Quick, test_lacp_timeout_prop "slow"; - "timeout_prop(fast)", `Quick, test_lacp_timeout_prop "fast"; - "aggregation_key(42)", `Quick, test_lacp_aggregation_key "42"; - "aggregation_key_vsctl", `Quick, test_lacp_aggregation_key_vsctl "42"; - "defaults_bond_create", `Quick, test_lacp_defaults_bond_create; - ] - ] +let suite = + [ + ( "test_lacp" + , [ + ("timeout_prop(slow)", `Quick, test_lacp_timeout_prop "slow") + ; ("timeout_prop(fast)", `Quick, test_lacp_timeout_prop "fast") + ; ("aggregation_key(42)", `Quick, test_lacp_aggregation_key "42") + ; ("aggregation_key_vsctl", `Quick, test_lacp_aggregation_key_vsctl "42") + ; ("defaults_bond_create", `Quick, test_lacp_defaults_bond_create) + ] ) + ] diff --git a/test/test_jsonrpc_client.ml b/test/test_jsonrpc_client.ml index af6fd9dad..21e3190ad 100644 --- a/test/test_jsonrpc_client.ml +++ b/test/test_jsonrpc_client.ml @@ -17,55 +17,58 @@ open Xapi_stdext_monadic.Either let dir = Filename.concat "test" "jsonrpc_files" -let jsonrpc_printer : Rpc.t Test_printers.printer = - Jsonrpc.to_string +let jsonrpc_printer : Rpc.t Test_printers.printer = Jsonrpc.to_string module Input_json_object = Generic.MakeStateless (struct - module Io = struct - type input_t = string - type output_t = (exn, Rpc.t) Xapi_stdext_monadic.Either.t - let string_of_input_t = Test_printers.string - let string_of_output_t = Test_printers.(either exn jsonrpc_printer) - end + module Io = struct + type input_t = string - let good_call = - let fin = open_in (Filename.concat dir "good_call.json") in - let s = input_line fin in - close_in fin; - Jsonrpc.of_string s + type output_t = (exn, Rpc.t) Xapi_stdext_monadic.Either.t - exception Parse_error + let string_of_input_t = Test_printers.string - let transform filename = - let fin = open_in (Filename.concat dir filename) in - let response = - try - let json = Jsonrpc_client.timeout_read (Unix.descr_of_in_channel fin) 5_000_000_000L in - let rpc = Jsonrpc.of_string ~strict:false json in - Right rpc - with - | End_of_file -> Left End_of_file - | _ -> Left Parse_error - in - close_in fin; - response + let string_of_output_t = Test_printers.(either exn jsonrpc_printer) + end - let tests = `QuickAndAutoDocumented [ - (* A file containing exactly one JSON object. *) - (* It has got curly braces inside strings to make it interesting. *) - "good_call.json", Right good_call; + let good_call = + let fin = open_in (Filename.concat dir "good_call.json") in + let s = input_line fin in + close_in fin ; Jsonrpc.of_string s - (* A file containing a partial JSON object. *) - "short_call.json", Left Parse_error; + exception Parse_error - (* A file containing a JSON object, plus some more characters at the end. *) - "good_call_plus.json", Right good_call; + let transform filename = + let fin = open_in (Filename.concat dir filename) in + let response = + try + let json = + Jsonrpc_client.timeout_read + (Unix.descr_of_in_channel fin) + 5_000_000_000L + in + let rpc = Jsonrpc.of_string ~strict:false json in + Right rpc + with + | End_of_file -> + Left End_of_file + | _ -> + Left Parse_error + in + close_in fin ; response - (* A file containing some invalid JSON object. *) - "bad_call.json", (Left Parse_error); - ] - end) + let tests = + `QuickAndAutoDocumented + [ + (* A file containing exactly one JSON object. *) + (* It has got curly braces inside strings to make it interesting. *) + ("good_call.json", Right good_call) + ; (* A file containing a partial JSON object. *) + ("short_call.json", Left Parse_error) + ; (* A file containing a JSON object, plus some more characters at the end. *) + ("good_call_plus.json", Right good_call) + ; (* A file containing some invalid JSON object. *) + ("bad_call.json", Left Parse_error) + ] +end) -let tests = - [ "json_rpc_client_input_json_object", Input_json_object.tests; - ] +let tests = [("json_rpc_client_input_json_object", Input_json_object.tests)] From 758238943e49fbfc67f239734326333db320e1f1 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 14 May 2020 10:31:44 +0100 Subject: [PATCH 240/260] maintenance: format comments with ocamlformat This is done after adding wrap-comments=true in .ocamlformat Signed-off-by: Pau Ruiz Safont --- lib/jsonrpc_client.ml | 12 +-- lib/jsonrpc_client.mli | 4 +- lib/network_config.ml | 3 +- lib/network_utils.ml | 110 +++++++++++++++------------ networkd/network_monitor_thread.ml | 4 +- networkd/network_server.ml | 43 ++++++----- profiling/coverage.ml | 10 +-- profiling/coverage.mli | 5 +- test/network_test_lacp_properties.ml | 4 +- test/test_jsonrpc_client.ml | 3 +- 10 files changed, 109 insertions(+), 89 deletions(-) diff --git a/lib/jsonrpc_client.ml b/lib/jsonrpc_client.ml index 64092b51a..b303e1a74 100644 --- a/lib/jsonrpc_client.ml +++ b/lib/jsonrpc_client.ml @@ -49,9 +49,9 @@ let timeout_read fd timeout = | Unix.Unix_error (Unix.EINTR, _, _) -> ([], [], []) in - (* This is not accurate the calculate time just for the select part. However, we - * think the read time will be minor comparing to the scale of tens of seconds. - * the current style will be much concise in code. *) + (* This is not accurate the calculate time just for the select part. + However, we think the read time will be minor comparing to the scale of + tens of seconds. the current style will be much concise in code. *) let remain_time = let used_time = get_total_used_time () in Int64.sub timeout used_time @@ -84,8 +84,10 @@ let timeout_read fd timeout = in inner timeout !json_rpc_max_len -(* Write as many bytes to a file descriptor as possible from data before a given clock time. *) -(* Raises Timeout exception if the number of bytes written is less than the specified length. *) +(* Write as many bytes to a file descriptor as possible from data before a given + clock time. *) +(* Raises Timeout exception if the number of bytes written is less than the + specified length. *) (* Writes into the file descriptor at the current cursor position. *) let timeout_write filedesc total_length data response_time = let write_start = Mtime_clock.counter () in diff --git a/lib/jsonrpc_client.mli b/lib/jsonrpc_client.mli index 2f92337e5..81f1e3866 100644 --- a/lib/jsonrpc_client.mli +++ b/lib/jsonrpc_client.mli @@ -30,5 +30,5 @@ val with_rpc : -> call:Rpc.call -> unit -> Rpc.response -(** Do an JSON-RPC call to a server that is listening on a Unix domain - * socket at the given path. *) +(** Do an JSON-RPC call to a server that is listening on a Unix domain socket at + the given path. *) diff --git a/lib/network_config.ml b/lib/network_config.ml index 4381cbd6d..58bf782c5 100644 --- a/lib/network_config.ml +++ b/lib/network_config.ml @@ -178,7 +178,8 @@ let write_config config = (Printexc.get_backtrace ()) ; raise Write_error -(* Porting network interaface to ppx: convert ipv4_routes from (string * int * string) list to {gateway:string; netmask:int; subnet:string} *) +(* Porting network interaface to ppx: convert ipv4_routes from [(string * int * + string) list] to [{gateway:string; netmask:int; subnet:string}] *) let convert_configuration cfg = let open Yojson.Safe in let convert_ipv4_routes cfg = diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 11e7cadb9..17ff799e1 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -188,7 +188,8 @@ module Sysfs = struct try let devpath = getpath name "device" in let driver_link = Unix.readlink (devpath ^ "/driver") in - (* filter out symlinks under device/driver which look like /../../../devices/xen-backend/vif- *) + (* filter out symlinks under device/driver which look like + /../../../devices/xen-backend/vif- *) not (List.mem "xen-backend" (Astring.String.cuts ~empty:false ~sep:"/" driver_link)) @@ -239,8 +240,8 @@ module Sysfs = struct Result.Error (Fail_to_get_driver_name, "Failed to get driver name for: " ^ dev) - (** Returns the features bitmap for the driver for [dev]. - * The features bitmap is a set of NETIF_F_ flags supported by its driver. *) + (** Returns the features bitmap for the driver for [dev]. The features bitmap + is a set of NETIF_F_ flags supported by its driver. *) let get_features dev = try Some (int_of_string (read_one_line (getpath dev "features"))) with _ -> None @@ -274,9 +275,11 @@ module Sysfs = struct let ifaces = list () in List.filter (fun name -> Sys.file_exists (getpath name "bridge")) ifaces - (** Returns (speed, duplex) for a given network interface: int megabits/s, Duplex. - * The units of speed are specified in pif_record in xen-api/xapi/records.ml. - * Note: these data are present in sysfs from kernel 2.6.33. *) + (** Returns (speed, duplex) for a given network interface: int megabits/s, + Duplex. The units of speed are specified in pif_record in + xen-api/xapi/records.ml. + + Note: these data are present in sysfs from kernel 2.6.33. *) let get_status name = let speed = getpath name "speed" |> fun p -> @@ -653,7 +656,8 @@ module Ip = struct with _ -> Result.Error (Fail_to_set_vf_vlan, "Failed to set VF VLAN for: " ^ dev) - (* We know some NICs do not support config VF Rate, so will explicitly tell XAPI this error*) + (* We know some NICs do not support config VF Rate, so will explicitly tell + XAPI this error*) let set_vf_rate dev index rate = try debug "Setting VF rate for dev: %s, index: %d, rate: %d" dev index rate ; @@ -670,9 +674,10 @@ module Linux_bonding = struct debug "Loading bonding driver" ; try ignore (call_script modprobe ["bonding"]) ; - (* is_bond_device() uses the contents of sysfs_bonding_masters to work out which devices - * have already been created. Unfortunately the driver creates "bond0" automatically at - * modprobe init. Get rid of this now or our accounting will go wrong. *) + (* is_bond_device() uses the contents of sysfs_bonding_masters to work out + which devices have already been created. Unfortunately the driver + creates "bond0" automatically at modprobe init. Get rid of this now or + our accounting will go wrong. *) Sysfs.write_one_line bonding_masters "-bond0" with _ -> error "Failed to load bonding driver" @@ -822,8 +827,8 @@ module Linux_bonding = struct debug "Current bond properties: %s" (String.concat ", " (List.map (fun (k, v) -> k ^ "=" ^ v) current_props)) ; - (* Find out which properties are known, but different from the current state, - * and only continue if there is at least one of those. *) + (* Find out which properties are known, but different from the current + state, and only continue if there is at least one of those. *) let props_to_update = List.filter (fun (prop, value) -> @@ -986,7 +991,8 @@ end = struct (* dhclient is not running, so we need to start it. *) ignore (start ~ipv6 interface options) else - (* dhclient is running - if the config has changed, update the config file and restart. *) + (* dhclient is running - if the config has changed, update the config file + and restart. *) let current_conf = read_conf_file ~ipv6 interface in let new_conf = generate_conf ~ipv6 interface options in if current_conf <> Some new_conf then ( @@ -1251,13 +1257,13 @@ module Ovs = struct with _ -> warn "Failed to set max-idle=%d on OVS" t let handle_vlan_bug_workaround override bridge = - (* This is a list of drivers that do support VLAN tx or rx acceleration, but - * to which the VLAN bug workaround should not be applied. This could be - * because these are known-good drivers (that is, they do not have any of - * the bugs that the workaround avoids) or because the VLAN bug workaround - * will not work for them and may cause other problems. - * - * This is a very short list because few drivers have been tested. *) + (* This is a list of drivers that do support VLAN tx or rx acceleration, + but to which the VLAN bug workaround should not be applied. This could + be because these are known-good drivers (that is, they do not have any + of the bugs that the workaround avoids) or because the VLAN bug + workaround will not work for them and may cause other problems. + + This is a very short list because few drivers have been tested. *) let no_vlan_workaround_drivers = ["bonding"] in let phy_interfaces = try @@ -1357,7 +1363,9 @@ module Ovs = struct (fun vif -> Astring.String.is_prefix ~affix:"vif" vif) bvifs in - (* The vifs may be large. However considering current XS limit of 1000VM*7NIC/VM + 800VLANs, the buffer of CLI should be sufficient for lots of vifxxxx.xx *) + (* The vifs may be large. However considering current XS limit of + 1000VM*7NIC/VM + 800VLANs, the buffer of CLI should be sufficient for + lots of vifxxxx.xx *) fork_script !inject_igmp_query_script ([ "--no-check-snooping-toggle" @@ -1493,14 +1501,16 @@ module Ovs = struct let del_old_arg = let real_bridge_exists () = try - (* `ovs-vsctl br-to-parent ` returns if is a current "real" bridge *) + (* `ovs-vsctl br-to-parent ` returns if is a + current "real" bridge *) vsctl ~log:false ["br-to-parent"; name] |> String.trim = name with _ -> false in if vlan <> None && real_bridge_exists () then - (* This is to handle the case that a "real" bridge (not a "fake" VLAN bridge) - already exists, while we need to create a VLAN bridge with the same name. - The bridge will be destroyed and recreated, and the interfaces on it are put back. *) + (* This is to handle the case that a "real" bridge (not a "fake" VLAN + bridge) already exists, while we need to create a VLAN bridge with + the same name. The bridge will be destroyed and recreated, and the + interfaces on it are put back. *) ["--"; "--if-exists"; "del-br"; name] else [] @@ -1882,19 +1892,19 @@ module Modprobe = struct ( Fail_to_write_modprobe_cfg , "Failed to write modprobe configuration file for: " ^ driver ) - (* - For a igb driver, the module config file will be at path `/etc/modprobe.d/igb.conf` - The module config file is like: - # VFs-param: max_vfs - # VFs-maxvfs-by-default: 7 - # VFs-maxvfs-by-user: - options igb max_vfs=7,7 - - Example of calls: - "igb" -> "VFs-param" -> Some "max_vfs" - "igb" -> "VFs-maxvfs-by-default" -> Some "7" - "igb" -> "VFs-maxvfs-by-user" -> None - "igb" -> "Not existed comments" -> None + (* For a igb driver, the module config file will be at path + `/etc/modprobe.d/igb.conf` + + The module config file is like: + # VFs-param: max_vfs + # VFs-maxvfs-by-default: 7 + # VFs-maxvfs-by-user: options igb max_vfs=7,7 + + Example of calls: + "igb" -> "VFs-param" -> Some "max_vfs" + "igb" -> "VFs-maxvfs-by-default" -> Some "7" + "igb" -> "VFs-maxvfs-by-user" -> None + "igb" -> "Not existed comments" -> None *) let get_config_from_comments driver = try @@ -1917,11 +1927,12 @@ module Modprobe = struct Some (String.trim k, String.trim v)) with _ -> [] - (* this function not returning None means that the driver doesn't suppport sysfs. - If a driver doesn't support sysfs, then we add VF_param into its driver modprobe - configuration. Therefore, from XAPI's perspective, if Modprobe.get_vf_param is - not None, the driver definitely should use modprobe other than sysfs, - and if Modprobe.get_vf_param is None, we just simple try sysfs. *) + (* this function not returning None means that the driver doesn't suppport + sysfs. If a driver doesn't support sysfs, then we add VF_param into its + driver modprobe configuration. Therefore, from XAPI's perspective, if + Modprobe.get_vf_param is not None, the driver definitely should use + modprobe other than sysfs, and if Modprobe.get_vf_param is None, we just + simple try sysfs. *) let get_vf_param config = try Some (List.assoc "VFs-param" config) with _ -> None @@ -1946,11 +1957,11 @@ module Modprobe = struct let config_sriov driver vf_param maxvfs = let open Rresult.R.Infix in Modinfo.is_param_array driver vf_param >>= fun is_array -> - (* To enable SR-IOV via modprobe configuration, we first determine if the driver requires - in the configuration an array like `options igb max_vfs=7,7,7,7` or a single value - like `options igb max_vfs=7`. If an array is required, this repeat times equals to - the number of devices with the same driver. - *) + (* To enable SR-IOV via modprobe configuration, we first determine if the + driver requires in the configuration an array like `options igb + max_vfs=7,7,7,7` or a single value like `options igb max_vfs=7`. If an + array is required, this repeat times equals to the number of devices with + the same driver. *) let repeat = if is_array then Sysfs.get_dev_nums_with_same_driver driver else 1 in @@ -1969,7 +1980,8 @@ module Modprobe = struct let parse_single_line s = let parse_driver_options s = match Astring.String.cut ~sep:"=" s with - (* has SR-IOV configuration but the max_vfs is exactly what we want to set, so no changes and return s *) + (* has SR-IOV configuration but the max_vfs is exactly what we want to + set, so no changes and return s *) | Some (k, v) when k = vf_param && v = option -> has_probe_conf := true ; s diff --git a/networkd/network_monitor_thread.ml b/networkd/network_monitor_thread.ml index 945a5d975..6b7092540 100644 --- a/networkd/network_monitor_thread.ml +++ b/networkd/network_monitor_thread.ml @@ -128,7 +128,7 @@ let get_link_stats () = in List.map (fun link -> (standardise_name (Link.get_name link), link)) links |> (* Only keep interfaces with prefixes on the whitelist, and exclude VLAN - devices (ethx.y). *) + devices (ethx.y). *) List.filter (fun (name, _) -> is_whitelisted name && not (is_vlan name)) in let devs = @@ -382,7 +382,7 @@ let rec ip_watcher () = && not (Astring.String.is_infix ~affix:"inet6 fe80" line) then ( (* Ignore changes for the next second, since they usually come in bursts, - * and signal only once. *) + * and signal only once. *) Thread.delay 1. ; clear_input readme ; signal_networking_change () diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 5c55ccc05..62049c223 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -127,10 +127,10 @@ module Sriov = struct debug "%s SR-IOV on a device: %s via modprobe" op dev ; (if enable then Modprobe.get_maxvfs driver config else Ok 0) >>= fun numvfs -> - (* CA-287340: Even if the current numvfs equals to the target numvfs, - it is still needed to update SR-IOV modprobe config file, as the - SR-IOV enabing takes effect after reboot. For example, a user - enables SR-IOV and disables it immediately without a reboot.*) + (* CA-287340: Even if the current numvfs equals to the target numvfs, it + is still needed to update SR-IOV modprobe config file, as the SR-IOV + enabing takes effect after reboot. For example, a user enables SR-IOV + and disables it immediately without a reboot.*) Modprobe.config_sriov driver vf_param numvfs >>= fun _ -> if numvfs = Sysfs.get_sriov_numvfs dev then Ok Modprobe_successful @@ -184,9 +184,11 @@ module Sriov = struct (fun () -> Result.Ok ()) mac >>= fun () -> - (* In order to ensure the Networkd to be idempotent, configuring VF with no VLAN and rate - have to reset vlan and rate, since the VF might have previous configuration. Refering to - http://gittup.org/cgi-bin/man/man2html?ip-link+8, set VLAN and rate to 0 means to reset them *) + (* In order to ensure the Networkd to be idempotent, configuring VF with no + VLAN and rate have to reset vlan and rate, since the VF might have + previous configuration. Refering to + http://gittup.org/cgi-bin/man/man2html?ip-link+8, set VLAN and rate to 0 + means to reset them *) config_or_otherwise_reset (Ip.set_vf_vlan dev index) (fun () -> Ip.set_vf_vlan dev index 0) vlan @@ -285,8 +287,8 @@ module Interface = struct ignore (Dhclient.stop name) ; Ip.flush_ip_addr name ) ; - (* the function is meant to be idempotent and we - * want to avoid CA-239919 *) + (* the function is meant to be idempotent and we want to avoid + CA-239919 *) let cur_addrs = Ip.get_ipv4 name in let rm_addrs = Xapi_stdext_std.Listext.List.set_difference cur_addrs addrs @@ -372,7 +374,8 @@ module Interface = struct Ip.flush_ip_addr ~ipv6:true name ; Ip.set_ipv6_link_local_addr name ; Sysctl.set_ipv6_autoconf name true - (* Cannot link set down/up due to CA-89882 - IPv4 default route cleared *) + (* Cannot link set down/up due to CA-89882 - IPv4 default route + cleared *) | Static6 addrs -> if Dhclient.is_running ~ipv6:true name then ignore (Dhclient.stop ~ipv6:true name) ; @@ -636,9 +639,11 @@ module Interface = struct ) ) -> update_config name c ; exec (fun () -> - (* We only apply the DNS settings when in static IPv4 mode to avoid conflicts with DHCP mode. - * The `dns` field should really be an option type so that we don't have to derive the intention - * of the caller by looking at other fields. *) + (* We only apply the DNS settings when in static IPv4 mode + to avoid conflicts with DHCP mode. * The `dns` field + should really be an option type so that we don't have to + derive the intention * of the caller by looking at other + fields. *) match ipv4_conf with | Static4 _ -> set_dns () dbg ~name ~nameservers ~domains @@ -899,8 +904,9 @@ module Bridge = struct (* Check if the VLAN is already in use by something else *) List.iter (fun (device, vlan', parent') -> - (* A device for the same VLAN (parent + tag), but with a different - * device name or not on the requested bridge is bad. *) + (* A device for the same VLAN (parent + tag), but with a + different * device name or not on the requested bridge is + bad. *) if parent' = parent && vlan' = vlan @@ -910,7 +916,8 @@ module Bridge = struct then raise (Network_error (Vlan_in_use (parent, vlan)))) (Proc.get_vlans ()) ; - (* Robustness enhancement: ensure there are no other VLANs in the bridge *) + (* Robustness enhancement: ensure there are no other VLANs in + the bridge *) let current_interfaces = List.filter (fun n -> @@ -1378,8 +1385,8 @@ let on_startup () = (fun () -> Bridge.determine_backend () ; let remove_centos_config () = - (* Remove DNSDEV and GATEWAYDEV from Centos networking file, because the interfere - * with this daemon. *) + (* Remove DNSDEV and GATEWAYDEV from Centos networking file, because the + interfere * with this daemon. *) try let file = String.trim diff --git a/profiling/coverage.ml b/profiling/coverage.ml index a99750d72..81c4761ca 100644 --- a/profiling/coverage.ml +++ b/profiling/coverage.ml @@ -1,10 +1,8 @@ -(** This module sets up the env variable for bisect_ppx which describes - * where log files are written. -*) +(** This module sets up the env variable for bisect_ppx which describes where + log files are written. *) -(** [init name] sets up coverage profiling for binary [name]. You could - * use [Sys.argv.(0)] for [name]. -*) +(** [init name] sets up coverage profiling for binary [name]. You could use + [Sys.argv.(0)] for [name]. *) let init name = let ( // ) = Filename.concat in diff --git a/profiling/coverage.mli b/profiling/coverage.mli index f50e8efbf..62875e11a 100644 --- a/profiling/coverage.mli +++ b/profiling/coverage.mli @@ -1,5 +1,4 @@ -(** [init name] sets up coverage profiling for binary [name]. You could - * use [Sys.argv.(0) for name -*) +(** [init name] sets up coverage profiling for binary [name]. You could use + [Sys.argv.(0) for name *) val init : string -> unit diff --git a/test/network_test_lacp_properties.ml b/test/network_test_lacp_properties.ml index 5330bd4be..a2d7fbba4 100644 --- a/test/network_test_lacp_properties.ml +++ b/test/network_test_lacp_properties.ml @@ -95,8 +95,8 @@ let test_lacp_defaults_bond_create () = in Ovs.create_bond bond ifaces bridge default_props |> ignore ; (* should not have any strings which contain lacp-aggregation-key *) - (*assert_bool "no default property for lacp_aggregation_key" - List.exists (fun s -> String.*) + (*assert_bool "no default property for lacp_aggregation_key" List.exists (fun + s -> String.*) List.iter (fun arg -> Alcotest.( diff --git a/test/test_jsonrpc_client.ml b/test/test_jsonrpc_client.ml index 21e3190ad..55554d55b 100644 --- a/test/test_jsonrpc_client.ml +++ b/test/test_jsonrpc_client.ml @@ -64,7 +64,8 @@ module Input_json_object = Generic.MakeStateless (struct ("good_call.json", Right good_call) ; (* A file containing a partial JSON object. *) ("short_call.json", Left Parse_error) - ; (* A file containing a JSON object, plus some more characters at the end. *) + ; (* A file containing a JSON object, plus some more characters at the + end. *) ("good_call_plus.json", Right good_call) ; (* A file containing some invalid JSON object. *) ("bad_call.json", Left Parse_error) From 98ed087058d794f10380c175750ea6cf1e884f67 Mon Sep 17 00:00:00 2001 From: Arne Wendt Date: Fri, 6 Mar 2020 14:17:02 +0100 Subject: [PATCH 241/260] allow the use of already enabled sr-iov virtual functions in sr-iov networks managed by xapi network server failed to use already enabled virtual functions, for network adapters that do not allow configurations via sysfs interface, but require manual configuration by user Signed-off-by: Arne Wendt --- networkd/network_server.ml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 62049c223..9a3741976 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -144,7 +144,14 @@ module Sriov = struct Sysfs.unbind_child_vfs dev >>= fun () -> Ok 0 ) >>= fun numvfs -> - Sysfs.set_sriov_numvfs dev numvfs >>= fun _ -> Ok Sysfs_successful + let sysfs_numvfs = Sysfs.get_sriov_numvfs dev in + ( if sysfs_numvfs <> 0 then ( + debug "%d vfs already enabled on device: %s" sysfs_numvfs dev ; + Ok () + ) else + Sysfs.set_sriov_numvfs dev numvfs + ) + >>= fun _ -> Ok Sysfs_successful let enable dbg name = Debug.with_thread_associated dbg From 6a053067e972cfca398504fc030c1347d38e6606 Mon Sep 17 00:00:00 2001 From: Arne Wendt Date: Thu, 12 Mar 2020 21:00:27 +0000 Subject: [PATCH 242/260] add support for enabling sr-iov-networks on adapters with already enabled sr-iov/vfs Manual configuration is assumed if: no modprobe template is present, setting numvfs to maxvfs via sysfs interface fails, but vfs are present. a new return `Manual_successful` is introduced. Signed-off-by: Arne Wendt --- networkd/network_server.ml | 47 ++++++++++++++++++++++++++------------ 1 file changed, 33 insertions(+), 14 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 9a3741976..e12599af0 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -137,21 +137,40 @@ module Sriov = struct else Ok Modprobe_successful_requires_reboot | None -> - debug "%s SR-IOV on a device: %s via sysfs" op dev ; - ( if enable then - Sysfs.get_sriov_maxvfs dev + (* enable: try sysfs interface to set numfvs = maxvfs. if fails, but vfs are enabled, assume manual configuration. + disable: Net.Sriov.disable will not be called for manually configured interfaces, as determined by `require_operation_on_pci_device` *) + let man_successful () = + debug "SR-IOV/VFs %sd manually on device: %s" op dev ; + Manual_successful + in + if enable then + let present_numvfs = Sysfs.get_sriov_numvfs dev in + match + Sysfs.get_sriov_maxvfs dev >>= fun maxvfs -> + maxvfs |> Sysfs.set_sriov_numvfs dev + with + | Ok _ -> + debug "%s SR-IOV on a device: %s via sysfs" op dev ; + Ok Sysfs_successful + | Error _ when present_numvfs > 0 -> + Ok (man_successful ()) + | exception _ when present_numvfs > 0 -> + Ok (man_successful ()) + | Error err -> + Error err + | exception e -> + let msg = + Printf.sprintf + "Error: trying sysfs SR-IOV interface failed with exception \ + %s on device: %s" + (Printexc.to_string e) dev + in + Error (Other, msg) else - Sysfs.unbind_child_vfs dev >>= fun () -> Ok 0 - ) - >>= fun numvfs -> - let sysfs_numvfs = Sysfs.get_sriov_numvfs dev in - ( if sysfs_numvfs <> 0 then ( - debug "%d vfs already enabled on device: %s" sysfs_numvfs dev ; - Ok () - ) else - Sysfs.set_sriov_numvfs dev numvfs - ) - >>= fun _ -> Ok Sysfs_successful + Sysfs.unbind_child_vfs dev >>= fun () -> + Sysfs.set_sriov_numvfs dev 0 >>= fun _ -> + debug "%s SR-IOV on a device: %s via sysfs" op dev ; + Ok Sysfs_successful let enable dbg name = Debug.with_thread_associated dbg From fcce7097f09a2aa33357ed912cf76f8387c5c19d Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 22 May 2020 11:12:32 +0100 Subject: [PATCH 243/260] CP-33121: remove stdext's monadic usage Signed-off-by: Pau Ruiz Safont --- networkd/dune | 1 - networkd/network_server.ml | 21 ++++++++++----------- test/test_jsonrpc_client.ml | 22 +++++++++++----------- xapi-networkd.opam | 1 - 4 files changed, 21 insertions(+), 24 deletions(-) diff --git a/networkd/dune b/networkd/dune index 1d8e733df..517379d57 100644 --- a/networkd/dune +++ b/networkd/dune @@ -32,7 +32,6 @@ rpclib systemd threads - xapi-stdext-monadic xapi-stdext-pervasives xapi-stdext-threads xapi-stdext-unix diff --git a/networkd/network_server.ml b/networkd/network_server.ml index e12599af0..b8000be58 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -14,7 +14,6 @@ open Network_utils open Network_interface -open Xapi_stdext_monadic module S = Network_interface.Interface_API (Idl.Exn.GenServer ()) @@ -226,8 +225,8 @@ module Sriov = struct let make_vf_config dbg pci_address (vf_info : sriov_pci_t) = Debug.with_thread_associated dbg (fun () -> - let vlan = Opt.map Int64.to_int vf_info.vlan - and rate = Opt.map Int64.to_int vf_info.rate + let vlan = Option.map Int64.to_int vf_info.vlan + and rate = Option.map Int64.to_int vf_info.rate and pcibuspath = Xcp_pci.string_of_address pci_address in debug "Config VF with pci address: %s" pcibuspath ; match make_vf_conf_internal pcibuspath vf_info.mac vlan rate with @@ -298,13 +297,15 @@ module Interface = struct Ip.flush_ip_addr name ) | DHCP4 -> - let open Xapi_stdext_monadic in let gateway = - Opt.default [] - (Opt.map (fun n -> [`gateway n]) !config.gateway_interface) + Option.fold ~none:[] + ~some:(fun n -> [`gateway n]) + !config.gateway_interface in let dns = - Opt.default [] (Opt.map (fun n -> [`dns n]) !config.dns_interface) + Option.fold ~none:[] + ~some:(fun n -> [`dns n]) + !config.dns_interface in let options = gateway @ dns in Dhclient.ensure_running name options @@ -886,9 +887,7 @@ module Bridge = struct ) in let old_igmp_snooping = Ovs.get_mcast_snooping_enable ~name in - Xapi_stdext_monadic.Opt.iter - (destroy_existing_vlan_ovs_bridge dbg name) - vlan ; + Option.iter (destroy_existing_vlan_ovs_bridge dbg name) vlan ; ignore (Ovs.create_bridge ?mac ~fail_mode ?external_id ?disable_in_band ?igmp_snooping vlan vlan_bug_workaround name) ; @@ -898,7 +897,7 @@ module Bridge = struct ignore (Brctl.create_bridge name) ; Brctl.set_forwarding_delay name 0 ; Sysfs.set_multicast_snooping name false ; - Xapi_stdext_monadic.Opt.iter (Ip.set_mac name) mac ; + Option.iter (Ip.set_mac name) mac ; match vlan with | None -> () diff --git a/test/test_jsonrpc_client.ml b/test/test_jsonrpc_client.ml index 55554d55b..0ef3acc2c 100644 --- a/test/test_jsonrpc_client.ml +++ b/test/test_jsonrpc_client.ml @@ -13,21 +13,21 @@ *) open Test_highlevel -open Xapi_stdext_monadic.Either let dir = Filename.concat "test" "jsonrpc_files" -let jsonrpc_printer : Rpc.t Test_printers.printer = Jsonrpc.to_string +let pp_jsonrpc fmt rpc = Format.fprintf fmt "%s" (Jsonrpc.to_string rpc) module Input_json_object = Generic.MakeStateless (struct module Io = struct type input_t = string - type output_t = (exn, Rpc.t) Xapi_stdext_monadic.Either.t + type output_t = (Rpc.t, exn) result let string_of_input_t = Test_printers.string - let string_of_output_t = Test_printers.(either exn jsonrpc_printer) + let string_of_output_t = + Fmt.(str "%a" Dump.(result ~ok:pp_jsonrpc ~error:exn)) end let good_call = @@ -47,12 +47,12 @@ module Input_json_object = Generic.MakeStateless (struct 5_000_000_000L in let rpc = Jsonrpc.of_string ~strict:false json in - Right rpc + Ok rpc with | End_of_file -> - Left End_of_file + Error End_of_file | _ -> - Left Parse_error + Error Parse_error in close_in fin ; response @@ -61,14 +61,14 @@ module Input_json_object = Generic.MakeStateless (struct [ (* A file containing exactly one JSON object. *) (* It has got curly braces inside strings to make it interesting. *) - ("good_call.json", Right good_call) + ("good_call.json", Ok good_call) ; (* A file containing a partial JSON object. *) - ("short_call.json", Left Parse_error) + ("short_call.json", Error Parse_error) ; (* A file containing a JSON object, plus some more characters at the end. *) - ("good_call_plus.json", Right good_call) + ("good_call_plus.json", Ok good_call) ; (* A file containing some invalid JSON object. *) - ("bad_call.json", Left Parse_error) + ("bad_call.json", Error Parse_error) ] end) diff --git a/xapi-networkd.opam b/xapi-networkd.opam index 9d44ba4ee..15db08c8d 100644 --- a/xapi-networkd.opam +++ b/xapi-networkd.opam @@ -20,7 +20,6 @@ depends: [ "systemd" "xapi-idl" "xapi-inventory" - "xapi-stdext-monadic" "xapi-stdext-pervasives" "xapi-stdext-threads" "xapi-stdext-unix" From 1be31d8f47fc3913b988f01a7d8b918fc8adbfdc Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 21 Aug 2020 13:56:43 +0100 Subject: [PATCH 244/260] CP-34942: update for rpclib 7 compatibility Signed-off-by: Pau Ruiz Safont --- networkd/network_server.ml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index b8000be58..5bb10e827 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -1385,7 +1385,11 @@ module PVS_proxy = struct let configure_site _dbg config = debug "Configuring PVS proxy for site %s" config.site_uuid ; let call = - {Rpc.name= "configure_site"; params= [Rpcmarshal.marshal t.ty config]} + { + Rpc.name= "configure_site" + ; params= [Rpcmarshal.marshal t.ty config] + ; notif= false + } in let _ = do_call call in () @@ -1398,6 +1402,7 @@ module PVS_proxy = struct name= "remove_site" ; params= [Dict [("site_uuid", Rpcmarshal.marshal Rpc.Types.string.ty uuid)]] + ; notif= false } in let _ = do_call call in From c8d56028712da98df3a2c9cd4b28ca634a418e2f Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 5 Oct 2020 09:41:22 +0100 Subject: [PATCH 245/260] CP-34942: update for rpclib 8 compatibility --- networkd/network_server.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 5bb10e827..8f2de8df7 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -1388,7 +1388,7 @@ module PVS_proxy = struct { Rpc.name= "configure_site" ; params= [Rpcmarshal.marshal t.ty config] - ; notif= false + ; is_notification= false } in let _ = do_call call in @@ -1402,7 +1402,7 @@ module PVS_proxy = struct name= "remove_site" ; params= [Dict [("site_uuid", Rpcmarshal.marshal Rpc.Types.string.ty uuid)]] - ; notif= false + ; is_notification= false } in let _ = do_call call in From ef395c03ab554dffe5c851c43b53da6ea502967f Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 7 Oct 2020 11:53:32 +0100 Subject: [PATCH 246/260] opam: tests depend on alcotest, not ounit Signed-off-by: Pau Ruiz Safont --- xapi-networkd.opam | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/xapi-networkd.opam b/xapi-networkd.opam index 15db08c8d..65dfc7fba 100644 --- a/xapi-networkd.opam +++ b/xapi-networkd.opam @@ -6,15 +6,15 @@ dev-repo: "git+https://github.com/xapi-project/xcp-networkd.git" bug-reports: "https://github.com/xapi-project/xcp-networkd/issues" build: [ ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name] {with-test} + ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] depends: [ - "astring" + "astring" + "alcotest" {with-test} "base-threads" "forkexec" "mtime" "netlink" - "ounit" "re" "rpclib" "systemd" From d4842e996529c28077c5472ab4e81b0c2015bf7e Mon Sep 17 00:00:00 2001 From: BenjiReis Date: Mon, 16 Nov 2020 09:37:47 +0100 Subject: [PATCH 247/260] add DNS servers when either IPv4 or IPv6 is configured and not using DHCP Signed-off-by: BenjiReis --- networkd/network_server.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 8f2de8df7..5f081dfda 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -666,16 +666,16 @@ module Interface = struct ) ) -> update_config name c ; exec (fun () -> - (* We only apply the DNS settings when in static IPv4 mode - to avoid conflicts with DHCP mode. * The `dns` field + (* We only apply the DNS settings when not in a DHCP mode + to avoid conflicts. * The `dns` field should really be an option type so that we don't have to derive the intention * of the caller by looking at other fields. *) - match ipv4_conf with - | Static4 _ -> - set_dns () dbg ~name ~nameservers ~domains - | _ -> - ()) ; + match (ipv4_conf, ipv6_conf) with + | (Static4 _, _) + | (_, Static6 _) + | (_, Autoconf6) -> set_dns () dbg ~name ~nameservers ~domains + | _ -> ()); exec (fun () -> set_ipv4_conf dbg name ipv4_conf) ; exec (fun () -> match ipv4_gateway with From 0813e0389efb078305a9d4c4064a04cac0b85b1f Mon Sep 17 00:00:00 2001 From: BenjiReis Date: Wed, 18 Nov 2020 12:12:43 +0100 Subject: [PATCH 248/260] remove useless '*' in comment Signed-off-by: BenjiReis --- networkd/network_server.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 5f081dfda..f190d624d 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -667,9 +667,9 @@ module Interface = struct update_config name c ; exec (fun () -> (* We only apply the DNS settings when not in a DHCP mode - to avoid conflicts. * The `dns` field + to avoid conflicts. The `dns` field should really be an option type so that we don't have to - derive the intention * of the caller by looking at other + derive the intention of the caller by looking at other fields. *) match (ipv4_conf, ipv6_conf) with | (Static4 _, _) From 8466947bf2fe17a210fa1af0e5839d61a2d55656 Mon Sep 17 00:00:00 2001 From: Ross Lagerwall Date: Tue, 2 Feb 2021 16:52:59 +0000 Subject: [PATCH 249/260] CA-347400: Pass lease file when stopping dhclient xcp-networkd calls "dhclient -r" which releases the current lease and stops the existing dhclient process. For some reason, dhclient skips calling dhclient-script unless the lease file is given on the command-line. This means that the dhclient hooks are not run which in turn means that NTP servers obtained from DHCP are not removed. Fix this by simply passing the lease file when stopping dhclient. Signed-off-by: Ross Lagerwall --- lib/network_utils.ml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 17ff799e1..b9129e1f0 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -976,7 +976,14 @@ end = struct try ignore (call_script dhclient - ["-r"; "-pf"; pid_file ~ipv6 interface; interface]) ; + [ + "-r" + ; "-pf" + ; pid_file ~ipv6 interface + ; "-lf" + ; lease_file ~ipv6 interface + ; interface + ]) ; Unix.unlink (pid_file ~ipv6 interface) with _ -> () From 5db1c73becc1409d9aaa9c73e63ea91711f023b2 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Fri, 12 Feb 2021 16:17:45 +0000 Subject: [PATCH 250/260] Maintenance: format code, remove OCamlformat constraint Just remove the constraint on the OCamlformat version and reformat the code. Signed-off-by: Christian Lindig --- .ocamlformat | 1 - networkd/network_server.ml | 8 ++++---- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index b4d356a77..ea8e56a85 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,5 +1,4 @@ profile=ocamlformat -version=0.14.1 indicate-multiline-delimiters=closing-on-separate-line if-then-else=fit-or-vertical dock-collection-brackets=true diff --git a/networkd/network_server.ml b/networkd/network_server.ml index f190d624d..173a425c1 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -672,10 +672,10 @@ module Interface = struct derive the intention of the caller by looking at other fields. *) match (ipv4_conf, ipv6_conf) with - | (Static4 _, _) - | (_, Static6 _) - | (_, Autoconf6) -> set_dns () dbg ~name ~nameservers ~domains - | _ -> ()); + | Static4 _, _ | _, Static6 _ | _, Autoconf6 -> + set_dns () dbg ~name ~nameservers ~domains + | _ -> + ()) ; exec (fun () -> set_ipv4_conf dbg name ipv4_conf) ; exec (fun () -> match ipv4_gateway with From 8678423dfe6d57a189d1f6456e0c24573a1b4080 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Fri, 12 Feb 2021 15:47:46 +0000 Subject: [PATCH 251/260] CA-351826 recognise link/infiniband MAC address xcp-networkd fails to recognise the MAC address of an infiniband NIC because it only looks for link/ether and misses link/infiniband. If the former fails, look for link/infiniband, too. This code could be made more general by using regular expressions for search rather than strings. However, this would create more changes which could complicate backports. Signed-off-by: Christian Lindig --- lib/network_utils.ml | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index b9129e1f0..16b57c2ab 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -484,7 +484,18 @@ module Ip = struct let get_mtu dev = int_of_string (List.hd (link dev "mtu")) - let get_mac dev = List.hd (link dev "link/ether") + let get_mac dev = + match link dev "link/ether" with + | [] -> ( + match link dev "link/infiniband" with + | m :: _ -> + m + | [] -> + error "can't find mac address for %s" dev ; + "" + ) + | m :: _ -> + m let set_mac dev mac = try ignore (link_set dev ["address"; mac]) with _ -> () From 9ddfbf968004a41279a2f9cfdec490ab5c545b1a Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Mon, 15 Feb 2021 09:28:09 +0000 Subject: [PATCH 252/260] CA-351826 fail if we can't find MAC address of interface Raise an internal error as this is unexpected and there is no good way to recover. Signed-off-by: Christian Lindig --- lib/network_utils.ml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index 16b57c2ab..b25af0b23 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -491,8 +491,11 @@ module Ip = struct | m :: _ -> m | [] -> - error "can't find mac address for %s" dev ; - "" + let msg = + Printf.sprintf "can't find mac address for %s (%s)" dev __LOC__ + in + error "%s" msg ; + raise (Network_error (Internal_error msg)) ) | m :: _ -> m From 45df4b1acdc3f808f0f09353dfc053cf0f80d4ed Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 16 Feb 2021 11:39:01 +0000 Subject: [PATCH 253/260] Remove usages of List.hd List.hd can raise exceptions in locations where they are not expected. Quite a few deals with string splits, these can be worked around to not use lists at all. Others need to raise a semantically-correct error to properly debug the issue. Signed-off-by: Pau Ruiz Safont --- lib/network_utils.ml | 18 +++--- networkd/network_server.ml | 127 ++++++++++++++++++++----------------- 2 files changed, 79 insertions(+), 66 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index b9129e1f0..f5e13cf91 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -161,8 +161,7 @@ module Sysfs = struct let read_one_line file = try - Unixext.string_of_file file |> String.split_on_char '\n' |> List.hd - (* Note: the list returned by split_on_char is guaranteed to be non-empty *) + Unixext.string_of_file file |> Astring.String.take ~sat:(( <> ) '\n') with | End_of_file -> "" @@ -204,7 +203,7 @@ module Sysfs = struct let get_pcibuspath name = try let devpath = Unix.readlink (getpath name "device") in - List.hd (List.rev (Astring.String.cuts ~empty:false ~sep:"/" devpath)) + Filename.basename devpath with _ -> "N/A" let get_pci_ids name = @@ -785,9 +784,7 @@ module Linux_bonding = struct let master_path = Unix.readlink master_symlink in let slaves_path = Filename.concat master_symlink "bonding/slaves" in Unix.access slaves_path [Unix.F_OK] ; - Some - (List.hd - (List.rev (Astring.String.cuts ~empty:false ~sep:"/" master_path))) + Some (Filename.basename master_path) with _ -> None let get_bond_active_slave master = @@ -806,9 +803,12 @@ module Linux_bonding = struct Sysfs.read_one_line (Sysfs.getpath master ("bonding/" ^ prop)) in if prop = "mode" then - Some - ( prop - , List.hd (Astring.String.cuts ~empty:false ~sep:" " bond_prop) ) + let get_mode line = + let a_space char = char = ' ' in + Astring.String.( + line |> drop ~sat:a_space |> take ~sat:(Fun.negate a_space)) + in + Some (prop, get_mode bond_prop) else Some (prop, bond_prop) with _ -> diff --git a/networkd/network_server.ml b/networkd/network_server.ml index f190d624d..496cd3176 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -903,13 +903,25 @@ module Bridge = struct () | Some (parent, vlan) -> let bridge_interfaces = Sysfs.bridge_to_interfaces name in + let parent_bridge_interfaces = + List.filter + (fun n -> + Astring.String.is_prefix ~affix:"eth" n + || Astring.String.is_prefix ~affix:"bond" n) + (Sysfs.bridge_to_interfaces parent) + in let parent_bridge_interface = - List.hd - (List.filter - (fun n -> - Astring.String.is_prefix ~affix:"eth" n - || Astring.String.is_prefix ~affix:"bond" n) - (Sysfs.bridge_to_interfaces parent)) + match parent_bridge_interfaces with + | [] -> + let msg = + Printf.sprintf + {|Interface for bridge parent "%s" of vlan %i not found|} + parent vlan + in + error "%s" msg ; + raise (Network_error (Internal_error msg)) + | iface :: _ -> + iface in let parent_interface = if need_enic_workaround () then ( @@ -1130,16 +1142,17 @@ module Bridge = struct = match !backend_kind with | Openvswitch -> ( - if List.length interfaces = 1 then ( - List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces ; - ignore (Ovs.create_port (List.hd interfaces) bridge) - ) else ( - if bond_mac = None then - warn "No MAC address specified for the bond" ; - ignore - (Ovs.create_bond ?mac:bond_mac name interfaces bridge - bond_properties) ; - List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces + ( match interfaces with + | [iface] -> + Interface.bring_up () dbg ~name:iface ; + ignore (Ovs.create_port iface bridge) + | _ -> + if bond_mac = None then + warn "No MAC address specified for the bond" ; + ignore + (Ovs.create_bond ?mac:bond_mac name interfaces bridge + bond_properties) ; + List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces ) ; if List.mem bridge !add_default then let mac = @@ -1160,39 +1173,39 @@ module Bridge = struct no MAC address was specified" name bridge ) - | Bridge -> - if List.length interfaces = 1 then - List.iter (fun name -> Interface.bring_up () dbg ~name) interfaces - else ( - Linux_bonding.add_bond_master name ; - let bond_properties = - if - List.mem_assoc "mode" bond_properties - && List.assoc "mode" bond_properties = "lacp" - then - Xapi_stdext_std.Listext.List.replace_assoc "mode" "802.3ad" - bond_properties - else - bond_properties - in - Linux_bonding.set_bond_properties name bond_properties ; - Linux_bonding.set_bond_slaves name interfaces ; - ( match bond_mac with - | Some mac -> - Ip.set_mac name mac - | None -> - warn "No MAC address specified for the bond" + | Bridge -> ( + match interfaces with + | [iface] -> + Interface.bring_up () dbg ~name:iface + | _ -> + ( Linux_bonding.add_bond_master name ; + let bond_properties = + match List.assoc_opt "mode" bond_properties with + | Some "lacp" -> + Xapi_stdext_std.Listext.List.replace_assoc "mode" "802.3ad" + bond_properties + | _ -> + bond_properties + in + Linux_bonding.set_bond_properties name bond_properties ; + Linux_bonding.set_bond_slaves name interfaces ; + ( match bond_mac with + | Some mac -> + Ip.set_mac name mac + | None -> + warn "No MAC address specified for the bond" + ) ; + Interface.bring_up () dbg ~name ) ; - Interface.bring_up () dbg ~name - ) ; - if need_enic_workaround () then ( - debug "Applying enic workaround: adding VLAN0 device to bridge" ; - Ip.create_vlan name 0 ; - let vlan0 = Ip.vlan_name name 0 in - Interface.bring_up () dbg ~name:vlan0 ; - ignore (Brctl.create_port bridge vlan0) - ) else - ignore (Brctl.create_port bridge name) + if need_enic_workaround () then ( + debug "Applying enic workaround: adding VLAN0 device to bridge" ; + Ip.create_vlan name 0 ; + let vlan0 = Ip.vlan_name name 0 in + Interface.bring_up () dbg ~name:vlan0 ; + ignore (Brctl.create_port bridge vlan0) + ) else + ignore (Brctl.create_port bridge name) + ) let add_pvs_proxy_port dbg bridge name _port = match !backend_kind with @@ -1266,7 +1279,7 @@ module Bridge = struct Ovs.get_real_bridge name |> Ovs.bridge_to_interfaces |> List.filter Sysfs.is_physical - | Bridge -> + | Bridge -> ( let ifaces = Sysfs.bridge_to_interfaces name in let vlan_ifaces = List.filter @@ -1281,16 +1294,16 @@ module Bridge = struct let physical_ifaces = List.filter (fun iface -> Sysfs.is_physical iface) ifaces in - if vlan_ifaces <> [] then - let _, _, parent = List.hd vlan_ifaces in - if Linux_bonding.is_bond_device parent then + match (vlan_ifaces, bond_ifaces) with + | (_, _, parent) :: _, _ when Linux_bonding.is_bond_device parent -> Linux_bonding.get_bond_slaves parent - else + | (_, _, parent) :: _, _ -> [parent] - else if bond_ifaces <> [] then - Linux_bonding.get_bond_slaves (List.hd bond_ifaces) - else - physical_ifaces) + | _, bond_iface :: _ -> + Linux_bonding.get_bond_slaves bond_iface + | [], [] -> + physical_ifaces + )) () let set_persistent dbg name value = From 57bd834b4f3e4e33efb42af7c7a3c4fac0c9c21f Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 16 Feb 2021 11:40:14 +0000 Subject: [PATCH 254/260] maintenance: use Stdlib's List.filter_map This is a cosmetic change Signed-off-by: Pau Ruiz Safont --- lib/network_utils.ml | 11 +++++------ networkd/network_server.ml | 12 +++--------- 2 files changed, 8 insertions(+), 15 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index f5e13cf91..aba2e26b3 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -540,11 +540,11 @@ module Ip = struct let get_ipv4 dev = let addrs = addr dev "inet" in - Xapi_stdext_std.Listext.List.filter_map split_addr addrs + List.filter_map split_addr addrs let get_ipv6 dev = let addrs = addr dev "inet6" in - Xapi_stdext_std.Listext.List.filter_map split_addr addrs + List.filter_map split_addr addrs let set_ip_addr dev (ip, prefixlen) = let addr = Printf.sprintf "%s/%d" (Unix.string_of_inet_addr ip) prefixlen in @@ -815,7 +815,7 @@ module Linux_bonding = struct debug "Failed to get property \"%s\" on bond %s" prop master ; None in - Xapi_stdext_std.Listext.List.filter_map get_prop known_props + List.filter_map get_prop known_props else ( debug "Bond %s does not exist; cannot get properties" master ; [] @@ -1495,7 +1495,7 @@ module Ovs = struct | None -> None in - Xapi_stdext_std.Listext.List.filter_map parse lines + List.filter_map parse lines in List.flatten (List.map @@ -1699,7 +1699,7 @@ module Ovs = struct ; ("lacp-actor-key", "other-config:lacp-actor-key") ]) and other_args = - Xapi_stdext_std.Listext.List.filter_map + List.filter_map (fun (k, v) -> if List.mem k known_props then None @@ -1915,7 +1915,6 @@ module Modprobe = struct *) let get_config_from_comments driver = try - let open Xapi_stdext_std.Listext in Unixext.read_lines ~path:(getpath driver) |> List.filter_map (fun x -> let line = String.trim x in diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 496cd3176..62a6c1212 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -1286,14 +1286,8 @@ module Bridge = struct (fun (bridge, _, _) -> List.mem bridge ifaces) (Proc.get_vlans ()) in - let bond_ifaces = - List.filter - (fun iface -> Linux_bonding.is_bond_device iface) - ifaces - in - let physical_ifaces = - List.filter (fun iface -> Sysfs.is_physical iface) ifaces - in + let bond_ifaces = List.filter Linux_bonding.is_bond_device ifaces in + let physical_ifaces = List.filter Sysfs.is_physical ifaces in match (vlan_ifaces, bond_ifaces) with | (_, _, parent) :: _, _ when Linux_bonding.is_bond_device parent -> Linux_bonding.get_bond_slaves parent @@ -1335,7 +1329,7 @@ module Bridge = struct (String.concat ", " (List.map (fun (name, _) -> name) persistent_config)) ; let vlan_parents = - Xapi_stdext_std.Listext.List.filter_map + List.filter_map (function | _, {vlan= Some (parent, _); _} -> if not (List.mem_assoc parent persistent_config) then From 9fde8303caa951c5c24729501600c8ffee7fedff Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 18 Feb 2021 14:31:01 +0000 Subject: [PATCH 255/260] ci: use github actions Signed-off-by: Pau Ruiz Safont --- .github/workflows/main.yml | 70 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 70 insertions(+) create mode 100644 .github/workflows/main.yml diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml new file mode 100644 index 000000000..d13cf4ed1 --- /dev/null +++ b/.github/workflows/main.yml @@ -0,0 +1,70 @@ +name: Build and test + +on: + push: + pull_request: + schedule: + # run daily, this refreshes the cache + - cron: '30 4 * * *' + +jobs: + ocaml-test: + name: Ocaml tests + runs-on: ubuntu-20.04 + env: + package: "xapi-networkd" + + steps: + - name: Checkout code + uses: actions/checkout@v2 + + - name: Pull configuration from xs-opam + run: | + curl --fail --silent https://raw.githubusercontent.com/xapi-project/xs-opam/master/tools/xs-opam-ci.env | cut -f2 -d " " > .env + + - name: Load environment file + id: dotenv + uses: falti/dotenv-action@v0.2.4 + + - name: Retrieve date for cache key + id: cache-key + run: echo "::set-output name=date::$(/bin/date -u "+%Y%m%d")" + shell: bash + + - name: Restore opam cache + id: opam-cache + uses: actions/cache@v2 + with: + path: "~/.opam" + # invalidate cache daily, gets built daily using a scheduled job + key: ${{ steps.cache-key.outputs.date }} + + - name: Use ocaml + uses: avsm/setup-ocaml@v1 + with: + ocaml-version: ${{ steps.dotenv.outputs.ocaml_version_full }} + opam-repository: ${{ steps.dotenv.outputs.repository }} + + - name: Update opam metadata + run: | + opam update + opam pin add . --no-action + + - name: Install external dependencies + run: opam depext -u ${{ env.package }} + + - name: Install dependencies + run: | + opam upgrade + opam install ${{ env.package }} --deps-only --with-test -v + + - name: Build + run: opam exec -- make + + - name: Run tests + run: opam exec -- make test + + - name: Uninstall unversioned packages + # This should purge them from the cache, unversioned package have + # 'master' as its version + run: opam list | awk -F " " '$2 == "master" { print $1 }' | xargs opam uninstall From 2be6755c14944e21cc3488c1690df3dd1e7abb10 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 18 Feb 2021 14:52:35 +0000 Subject: [PATCH 256/260] ci: remove travis workflow Signed-off-by: Pau Ruiz Safont --- .travis.yml | 12 ------------ 1 file changed, 12 deletions(-) delete mode 100644 .travis.yml diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index ec363c8e5..000000000 --- a/.travis.yml +++ /dev/null @@ -1,12 +0,0 @@ -language: c -service: docker -install: - - wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh - - wget https://raw.githubusercontent.com/xapi-project/xs-opam/master/tools/xs-opam-ci.env - - source xs-opam-ci.env -script: bash -ex .travis-docker.sh -env: - global: - - PINS="xapi-networkd:." - jobs: - - PACKAGE="xapi-networkd" From 6db73c0267dd91261aa19c1a30cbb16a94c4e08d Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Thu, 25 Feb 2021 17:06:47 +0000 Subject: [PATCH 257/260] CA-351826 ensure PIF is an ethernet device list() scans for network devices. Since we only knowo how to handle ethernet devices, check the type of the device and ignore non-ethernet devices. This should in particular skip over Infiniband devices. Signed-off-by: Christian Lindig --- lib/network_utils.ml | 32 +++++++++++++++++++++++--------- 1 file changed, 23 insertions(+), 9 deletions(-) diff --git a/lib/network_utils.ml b/lib/network_utils.ml index b25af0b23..b7ecc1eae 100644 --- a/lib/network_utils.ml +++ b/lib/network_utils.ml @@ -141,15 +141,6 @@ let fork_script ?on_error ?log script args = check_n_run ?on_error ?log fork_script_internal script args module Sysfs = struct - let list () = - let all = Array.to_list (Sys.readdir "/sys/class/net") in - List.filter (fun name -> Sys.is_directory ("/sys/class/net/" ^ name)) all - - let exists dev = List.mem dev @@ list () - - let assert_exists dev = - if not @@ exists dev then - raise (Network_error (Interface_does_not_exist dev)) let list_drivers () = try Array.to_list (Sys.readdir "/sys/bus/pci/drivers") @@ -195,6 +186,29 @@ module Sysfs = struct (Astring.String.cuts ~empty:false ~sep:"/" driver_link)) with _ -> false + (* device types are defined in linux/if_arp.h *) + let is_ether_device name = + match int_of_string (read_one_line (getpath name "type")) with + | 1 -> + true + | _ -> + false + | exception _ -> + false + + let list () = + let is_dir name = Sys.is_directory ("/sys/class/net/" ^ name) in + Sys.readdir "/sys/class/net" + |> Array.to_list + |> List.filter (fun name -> is_dir name && is_ether_device name) + + let exists dev = List.mem dev @@ list () + + let assert_exists dev = + if not @@ exists dev then + raise (Network_error (Interface_does_not_exist dev)) + + let get_carrier name = try let i = int_of_string (read_one_line (getpath name "carrier")) in From 61a3018179dfb4b79753aa987d1f2337ea8182e1 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 9 Mar 2021 11:55:43 +0000 Subject: [PATCH 258/260] CA-352465: Fix refactoring bug in add_basic_port The call to Brctl.create_port must always be done for the Bridge case. Signed-off-by: Rob Hoes --- networkd/network_server.ml | 31 +++++++++++++++---------------- 1 file changed, 15 insertions(+), 16 deletions(-) diff --git a/networkd/network_server.ml b/networkd/network_server.ml index 30dcdf6d2..352fdc229 100644 --- a/networkd/network_server.ml +++ b/networkd/network_server.ml @@ -1173,12 +1173,12 @@ module Bridge = struct no MAC address was specified" name bridge ) - | Bridge -> ( - match interfaces with - | [iface] -> - Interface.bring_up () dbg ~name:iface - | _ -> - ( Linux_bonding.add_bond_master name ; + | Bridge -> + ( match interfaces with + | [iface] -> + Interface.bring_up () dbg ~name:iface + | _ -> + Linux_bonding.add_bond_master name ; let bond_properties = match List.assoc_opt "mode" bond_properties with | Some "lacp" -> @@ -1196,16 +1196,15 @@ module Bridge = struct warn "No MAC address specified for the bond" ) ; Interface.bring_up () dbg ~name - ) ; - if need_enic_workaround () then ( - debug "Applying enic workaround: adding VLAN0 device to bridge" ; - Ip.create_vlan name 0 ; - let vlan0 = Ip.vlan_name name 0 in - Interface.bring_up () dbg ~name:vlan0 ; - ignore (Brctl.create_port bridge vlan0) - ) else - ignore (Brctl.create_port bridge name) - ) + ) ; + if need_enic_workaround () then ( + debug "Applying enic workaround: adding VLAN0 device to bridge" ; + Ip.create_vlan name 0 ; + let vlan0 = Ip.vlan_name name 0 in + Interface.bring_up () dbg ~name:vlan0 ; + ignore (Brctl.create_port bridge vlan0) + ) else + ignore (Brctl.create_port bridge name) let add_pvs_proxy_port dbg bridge name _port = match !backend_kind with From aab02aaf36c5bce5c0c1ce3e39ddefb181b8c911 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 25 May 2021 14:44:08 +0100 Subject: [PATCH 259/260] maintenance: explicitly import xapi_stdext_std It's being imported transitively using xapi_stdext_unix, but this will break when unixexts drops that dependency as it isn't using it. Signed-off-by: Pau Ruiz Safont --- lib/dune | 1 + xapi-networkd.opam | 1 + 2 files changed, 2 insertions(+) diff --git a/lib/dune b/lib/dune index 1d1fa10e3..ef033810f 100644 --- a/lib/dune +++ b/lib/dune @@ -9,6 +9,7 @@ systemd threads re.perl + xapi-stdext-std xapi-stdext-unix xapi-inventory xapi-idl.network) diff --git a/xapi-networkd.opam b/xapi-networkd.opam index 65dfc7fba..0b6c4dce9 100644 --- a/xapi-networkd.opam +++ b/xapi-networkd.opam @@ -21,6 +21,7 @@ depends: [ "xapi-idl" "xapi-inventory" "xapi-stdext-pervasives" + "xapi-stdext-std" "xapi-stdext-threads" "xapi-stdext-unix" "xapi-test-utils" From 6e874d4405519c1ef11c98b867e260f4b9bf6984 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 1 Jun 2021 10:05:46 +0100 Subject: [PATCH 260/260] ci: avoid disabling CI workflows If there are no changes for around 2 months while a workflow runs daily github disables it. This makes us unable to detect when PR is breaking the daemon. Disable scheduled workflows and cache as it's not worth when the cache isn't refreshed periodically. Signed-off-by: Pau Ruiz Safont --- .github/workflows/main.yml | 23 +---------------------- 1 file changed, 1 insertion(+), 22 deletions(-) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index d13cf4ed1..94e7b3454 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -3,9 +3,6 @@ name: Build and test on: push: pull_request: - schedule: - # run daily, this refreshes the cache - - cron: '30 4 * * *' jobs: ocaml-test: @@ -24,20 +21,7 @@ jobs: - name: Load environment file id: dotenv - uses: falti/dotenv-action@v0.2.4 - - - name: Retrieve date for cache key - id: cache-key - run: echo "::set-output name=date::$(/bin/date -u "+%Y%m%d")" - shell: bash - - - name: Restore opam cache - id: opam-cache - uses: actions/cache@v2 - with: - path: "~/.opam" - # invalidate cache daily, gets built daily using a scheduled job - key: ${{ steps.cache-key.outputs.date }} + uses: falti/dotenv-action@v0.2.5 - name: Use ocaml uses: avsm/setup-ocaml@v1 @@ -63,8 +47,3 @@ jobs: - name: Run tests run: opam exec -- make test - - - name: Uninstall unversioned packages - # This should purge them from the cache, unversioned package have - # 'master' as its version - run: opam list | awk -F " " '$2 == "master" { print $1 }' | xargs opam uninstall