mptcp-pm 0.0.4 → 0.0.5
raw patch · 23 files changed
+1390/−1144 lines, 23 filesdep +lensdep +mptcpdep +pretty-simplenew-component:exe:mptcp-pm
Dependencies added: lens, mptcp, pretty-simple
Files
- README.md +9/−8
- headers/linux/mptcp.h +0/−151
- headers/linux/mptcp_v0.h +151/−0
- headers/linux/mptcp_v1.h +222/−0
- mptcp-pm.cabal +60/−25
- src/Net/Mptcp.hs +0/−486
- src/Net/Mptcp/Constants.chs +0/−50
- src/Net/Mptcp/Constants.hs +5/−0
- src/Net/Mptcp/Netlink.hs +52/−0
- src/Net/Mptcp/PathManager.hs +50/−44
- src/Net/Mptcp/PathManager/Default.hs +0/−79
- src/Net/Mptcp/PathManager/Upstream/NdiffPorts.hs +99/−0
- src/Net/Mptcp/Types.hs +46/−0
- src/Net/Mptcp/Upstream/Commands.hs +329/−0
- src/Net/Mptcp/Upstream/Constants.chs +61/−0
- src/Net/Mptcp/Utils.hs +32/−0
- src/Net/SockDiag.hs +36/−25
- src/Net/Tcp.hs +0/−20
- src/Net/Tcp/Constants.chs +3/−3
- src/Net/Tcp/Definitions.hs +0/−84
- src/Netlink/Route.hs +30/−0
- src/app/Main.hs +178/−153
- test/Main.hs +27/−16
README.md view
@@ -1,7 +1,9 @@ [![Hackage][hk-img]][hk] -This is a userspace path manager for the [linux multipath TCP+# Presentation+This is a userspace mptcp path manager for the [linux multipath TCP kernel][mptcp-fork], starting from version v0.95.+It now also supports the upstream linux kernel. This allows to monitor MPTCP connections and control what subflows to create and with a custom kernel it can even set specific values for the congestion windows.@@ -13,24 +15,23 @@ With a custom netlink and kernel Compile the custom netlink library with ```-$ cabal configure --enable-library-profiling+$ cabal configure ``` You may need some headers as well (NOTE: reference cabal.project instead): ```-kernel $ make headers_install-$ cabal configure --package-db ~/netlink-hs/dist/package.conf.inplace --extra-include-dirs=~/mptcp/build/usr/include -v3 --enable-profiling+$ cabal configure --extra-include-dirs=~/mptcp/build/usr/include+# or on nix you can also pass $(nix-build -A linuxHeaders)/include+# e.g., `cabal build --extra-include-dirs=/nix/store/3kag193bcwcslzz83chy93ryjv218rbp-linux-headers-5.14/include` ``` -To compile the doc (and understand why HLS fails displaying anything)-`cabal haddock --all`- # Usage The netlink module asks for `GENL_ADMIN_PERM` which requires the `CAP_NET_ADMIN` privilege. You can assign this privilege via: ```-sudo setcap cap_net_admin+ep hs/dist-newstyle/build/x86_64-linux/ghc-8.6.3/netlink-pm-1.0.0/x/daemon/build/daemon/daemon+res=$(cabal list-bin exe:mptcp-manager)+sudo setcap cap_net_admin+ep "$res" ``` Enter the development shell and start the daemon:
− headers/linux/mptcp.h
@@ -1,151 +0,0 @@-/* SPDX-License-Identifier: GPL-2.0 WITH Linux-syscall-note */-/*- * Netlink API for Multipath TCP- *- * Author: Gregory Detal <gregory.detal@tessares.net>- *- * This program is free software; you can redistribute it and/or- * modify it under the terms of the GNU General Public License- * as published by the Free Software Foundation; either version- * 2 of the License, or (at your option) any later version.- */--#ifndef _LINUX_MPTCP_H-#define _LINUX_MPTCP_H--#define MPTCP_GENL_NAME "mptcp"-#define MPTCP_GENL_EV_GRP_NAME "mptcp_events"-#define MPTCP_GENL_CMD_GRP_NAME "mptcp_commands"-#define MPTCP_GENL_VER 0x1--/*- * ATTR types defined for MPTCP- */-enum {- MPTCP_ATTR_UNSPEC = 0,-- MPTCP_ATTR_TOKEN, /* u32 */- MPTCP_ATTR_FAMILY, /* u16 */- MPTCP_ATTR_LOC_ID, /* u8 */- MPTCP_ATTR_REM_ID, /* u8 */- MPTCP_ATTR_SADDR4, /* u32 */- MPTCP_ATTR_SADDR6, /* struct in6_addr */- MPTCP_ATTR_DADDR4, /* u32 */- MPTCP_ATTR_DADDR6, /* struct in6_addr */- MPTCP_ATTR_SPORT, /* u16 */- MPTCP_ATTR_DPORT, /* u16 */- MPTCP_ATTR_BACKUP, /* u8 */- MPTCP_ATTR_ERROR, /* u8 */- MPTCP_ATTR_FLAGS, /* u16 */- MPTCP_ATTR_TIMEOUT, /* u32 */- MPTCP_ATTR_IF_IDX, /* s32 */- MPTCP_ATTR_CWND, /* u32 */-- __MPTCP_ATTR_AFTER_LAST-};--#define MPTCP_ATTR_MAX (__MPTCP_ATTR_AFTER_LAST - 1)--/*- * Events generated by MPTCP:- * - MPTCP_EVENT_CREATED: token, family, saddr4 | saddr6, daddr4 | daddr6,- * sport, dport- * A new connection has been created. It is the good time to allocate- * memory and send ADD_ADDR if needed. Depending on the traffic-patterns- * it can take a long time until the MPTCP_EVENT_ESTABLISHED is sent.- *- * - MPTCP_EVENT_ESTABLISHED: token, family, saddr4 | saddr6, daddr4 | daddr6,- * sport, dport- * A connection is established (can start new subflows).- *- * - MPTCP_EVENT_CLOSED: token- * A connection has stopped.- *- * - MPTCP_EVENT_ANNOUNCED: token, rem_id, family, daddr4 | daddr6 [, dport]- * A new address has been announced by the peer.- *- * - MPTCP_EVENT_REMOVED: token, rem_id- * An address has been lost by the peer.- *- * - MPTCP_EVENT_SUB_ESTABLISHED: token, family, saddr4 | saddr6,- * daddr4 | daddr6, sport, dport, backup,- * if_idx [, error]- * A new subflow has been established. 'error' should not be set.- *- * - MPTCP_EVENT_SUB_CLOSED: token, family, saddr4 | saddr6, daddr4 | daddr6,- * sport, dport, backup, if_idx [, error]- * A subflow has been closed. An error (copy of sk_err) could be set if an- * error has been detected for this subflow.- *- * - MPTCP_EVENT_SUB_PRIORITY: token, family, saddr4 | saddr6, daddr4 | daddr6,- * sport, dport, backup, if_idx [, error]- * The priority of a subflow has changed. 'error' should not be set.- *- * Commands for MPTCP:- * - MPTCP_CMD_ANNOUNCE: token, loc_id, family, saddr4 | saddr6 [, sport]- * Announce a new address to the peer.- *- * - MPTCP_CMD_REMOVE: token, loc_id- * Announce that an address has been lost to the peer.- *- * - MPTCP_CMD_SUB_CREATE: token, family, loc_id, rem_id, [saddr4 | saddr6,- * daddr4 | daddr6, dport [, sport, backup, if_idx]]- * Create a new subflow.- *- * - MPTCP_CMD_SUB_DESTROY: token, family, saddr4 | saddr6, daddr4 | daddr6,- * sport, dport- * Close a subflow.- *- * - MPTCP_CMD_SUB_PRIORITY: token, family, saddr4 | saddr6, daddr4 | daddr6,- * sport, dport, backup- * Change the priority of a subflow.- *- * - MPTCP_CMD_SET_FILTER: flags- * Set the filter on events. Set MPTCPF_* flags to only receive specific- * events. Default is to receive all events.- *- * - MPTCP_CMD_EXIST: token- * Check if this token is linked to an existing socket.- */-enum {- MPTCP_CMD_UNSPEC = 0,-- MPTCP_EVENT_CREATED,- MPTCP_EVENT_ESTABLISHED,- MPTCP_EVENT_CLOSED,-- MPTCP_CMD_ANNOUNCE,- MPTCP_CMD_REMOVE,- MPTCP_EVENT_ANNOUNCED,- MPTCP_EVENT_REMOVED,-- MPTCP_CMD_SUB_CREATE,- MPTCP_CMD_SUB_DESTROY,- MPTCP_EVENT_SUB_ESTABLISHED,- MPTCP_EVENT_SUB_CLOSED,-- MPTCP_CMD_SUB_PRIORITY,- MPTCP_EVENT_SUB_PRIORITY,-- MPTCP_CMD_SET_FILTER,-- MPTCP_CMD_EXIST,- MPTCP_CMD_SND_CLAMP_WINDOW,-- __MPTCP_CMD_AFTER_LAST-};--#define MPTCP_CMD_MAX (__MPTCP_CMD_AFTER_LAST - 1)--enum {- MPTCPF_EVENT_CREATED = (1 << 1),- MPTCPF_EVENT_ESTABLISHED = (1 << 2),- MPTCPF_EVENT_CLOSED = (1 << 3),- MPTCPF_EVENT_ANNOUNCED = (1 << 4),- MPTCPF_EVENT_REMOVED = (1 << 5),- MPTCPF_EVENT_SUB_ESTABLISHED = (1 << 6),- MPTCPF_EVENT_SUB_CLOSED = (1 << 7),- MPTCPF_EVENT_SUB_PRIORITY = (1 << 8),-};--#endif /* _LINUX_MPTCP_H */
+ headers/linux/mptcp_v0.h view
@@ -0,0 +1,151 @@+/* SPDX-License-Identifier: GPL-2.0 WITH Linux-syscall-note */+/*+ * Netlink API for Multipath TCP+ *+ * Author: Gregory Detal <gregory.detal@tessares.net>+ *+ * This program is free software; you can redistribute it and/or+ * modify it under the terms of the GNU General Public License+ * as published by the Free Software Foundation; either version+ * 2 of the License, or (at your option) any later version.+ */++#ifndef _LINUX_MPTCP_H+#define _LINUX_MPTCP_H++#define MPTCP_GENL_NAME "mptcp"+#define MPTCP_GENL_EV_GRP_NAME "mptcp_events"+#define MPTCP_GENL_CMD_GRP_NAME "mptcp_commands"+#define MPTCP_GENL_VER 0x1++/*+ * ATTR types defined for MPTCP+ */+enum {+ MPTCP_ATTR_UNSPEC = 0,++ MPTCP_ATTR_TOKEN, /* u32 */+ MPTCP_ATTR_FAMILY, /* u16 */+ MPTCP_ATTR_LOC_ID, /* u8 */+ MPTCP_ATTR_REM_ID, /* u8 */+ MPTCP_ATTR_SADDR4, /* u32 */+ MPTCP_ATTR_SADDR6, /* struct in6_addr */+ MPTCP_ATTR_DADDR4, /* u32 */+ MPTCP_ATTR_DADDR6, /* struct in6_addr */+ MPTCP_ATTR_SPORT, /* u16 */+ MPTCP_ATTR_DPORT, /* u16 */+ MPTCP_ATTR_BACKUP, /* u8 */+ MPTCP_ATTR_ERROR, /* u8 */+ MPTCP_ATTR_FLAGS, /* u16 */+ MPTCP_ATTR_TIMEOUT, /* u32 */+ MPTCP_ATTR_IF_IDX, /* s32 */++ __MPTCP_ATTR_AFTER_LAST+};++#define MPTCP_ATTR_MAX (__MPTCP_ATTR_AFTER_LAST - 1)++/*+ * Events generated by MPTCP:+ * - MPTCP_EVENT_CREATED: token, family, saddr4 | saddr6, daddr4 | daddr6,+ * sport, dport+ * A new connection has been created. It is the good time to allocate+ * memory and send ADD_ADDR if needed. Depending on the traffic-patterns+ * it can take a long time until the MPTCP_EVENT_ESTABLISHED is sent.+ *+ * - MPTCP_EVENT_ESTABLISHED: token, family, saddr4 | saddr6, daddr4 | daddr6,+ * sport, dport+ * A connection is established (can start new subflows).+ *+ * - MPTCP_EVENT_CLOSED: token+ * A connection has stopped.+ *+ * - MPTCP_EVENT_ANNOUNCED: token, rem_id, family, daddr4 | daddr6 [, dport]+ * A new address has been announced by the peer.+ *+ * - MPTCP_EVENT_REMOVED: token, rem_id+ * An address has been lost by the peer.+ *+ * - MPTCP_EVENT_SUB_ESTABLISHED: token, family, loc_id, rem_id,+ * saddr4 | saddr6, daddr4 | daddr6, sport,+ * dport, backup, if_idx [, error]+ * A new subflow has been established. 'error' should not be set.+ *+ * - MPTCP_EVENT_SUB_CLOSED: token, family, loc_id, rem_id, saddr4 | saddr6,+ * daddr4 | daddr6, sport, dport, backup, if_idx+ * [, error]+ * A subflow has been closed. An error (copy of sk_err) could be set if an+ * error has been detected for this subflow.+ *+ * - MPTCP_EVENT_SUB_PRIORITY: token, family, loc_id, rem_id, saddr4 | saddr6,+ * daddr4 | daddr6, sport, dport, backup, if_idx+ * [, error]+ * The priority of a subflow has changed. 'error' should not be set.+ *+ * Commands for MPTCP:+ * - MPTCP_CMD_ANNOUNCE: token, loc_id, family, saddr4 | saddr6 [, sport]+ * Announce a new address to the peer.+ *+ * - MPTCP_CMD_REMOVE: token, loc_id+ * Announce that an address has been lost to the peer.+ *+ * - MPTCP_CMD_SUB_CREATE: token, family, loc_id, rem_id, daddr4 | daddr6,+ * dport [, saddr4 | saddr6, sport, backup, if_idx]+ * Create a new subflow.+ *+ * - MPTCP_CMD_SUB_DESTROY: token, family, saddr4 | saddr6, daddr4 | daddr6,+ * sport, dport+ * Close a subflow.+ *+ * - MPTCP_CMD_SUB_PRIORITY: token, family, saddr4 | saddr6, daddr4 | daddr6,+ * sport, dport, backup+ * Change the priority of a subflow.+ *+ * - MPTCP_CMD_SET_FILTER: flags+ * Set the filter on events. Set MPTCPF_* flags to only receive specific+ * events. Default is to receive all events.+ *+ * - MPTCP_CMD_EXIST: token+ * Check if this token is linked to an existing socket.+ */+enum {+ MPTCP_CMD_UNSPEC = 0,++ MPTCP_EVENT_CREATED,+ MPTCP_EVENT_ESTABLISHED,+ MPTCP_EVENT_CLOSED,++ MPTCP_CMD_ANNOUNCE,+ MPTCP_CMD_REMOVE,+ MPTCP_EVENT_ANNOUNCED,+ MPTCP_EVENT_REMOVED,++ MPTCP_CMD_SUB_CREATE,+ MPTCP_CMD_SUB_DESTROY,+ MPTCP_EVENT_SUB_ESTABLISHED,+ MPTCP_EVENT_SUB_CLOSED,++ MPTCP_CMD_SUB_PRIORITY,+ MPTCP_EVENT_SUB_PRIORITY,++ MPTCP_CMD_SET_FILTER,++ MPTCP_CMD_EXIST,++ __MPTCP_CMD_AFTER_LAST+};++#define MPTCP_CMD_MAX (__MPTCP_CMD_AFTER_LAST - 1)++enum {+ MPTCPF_EVENT_CREATED = (1 << 1),+ MPTCPF_EVENT_ESTABLISHED = (1 << 2),+ MPTCPF_EVENT_CLOSED = (1 << 3),+ MPTCPF_EVENT_ANNOUNCED = (1 << 4),+ MPTCPF_EVENT_REMOVED = (1 << 5),+ MPTCPF_EVENT_SUB_ESTABLISHED = (1 << 6),+ MPTCPF_EVENT_SUB_CLOSED = (1 << 7),+ MPTCPF_EVENT_SUB_PRIORITY = (1 << 8),+};++#endif /* _LINUX_MPTCP_H */
+ headers/linux/mptcp_v1.h view
@@ -0,0 +1,222 @@+/* SPDX-License-Identifier: GPL-2.0+ WITH Linux-syscall-note */+#ifndef _UAPI_MPTCP_H+#define _UAPI_MPTCP_H+++#define MPTCP_SUBFLOW_FLAG_MCAP_REM _BITUL(0)+#define MPTCP_SUBFLOW_FLAG_MCAP_LOC _BITUL(1)+#define MPTCP_SUBFLOW_FLAG_JOIN_REM _BITUL(2)+#define MPTCP_SUBFLOW_FLAG_JOIN_LOC _BITUL(3)+#define MPTCP_SUBFLOW_FLAG_BKUP_REM _BITUL(4)+#define MPTCP_SUBFLOW_FLAG_BKUP_LOC _BITUL(5)+#define MPTCP_SUBFLOW_FLAG_FULLY_ESTABLISHED _BITUL(6)+#define MPTCP_SUBFLOW_FLAG_CONNECTED _BITUL(7)+#define MPTCP_SUBFLOW_FLAG_MAPVALID _BITUL(8)++enum {+ MPTCP_SUBFLOW_ATTR_UNSPEC,+ MPTCP_SUBFLOW_ATTR_TOKEN_REM,+ MPTCP_SUBFLOW_ATTR_TOKEN_LOC,+ MPTCP_SUBFLOW_ATTR_RELWRITE_SEQ,+ MPTCP_SUBFLOW_ATTR_MAP_SEQ,+ MPTCP_SUBFLOW_ATTR_MAP_SFSEQ,+ MPTCP_SUBFLOW_ATTR_SSN_OFFSET,+ MPTCP_SUBFLOW_ATTR_MAP_DATALEN,+ MPTCP_SUBFLOW_ATTR_FLAGS,+ MPTCP_SUBFLOW_ATTR_ID_REM,+ MPTCP_SUBFLOW_ATTR_ID_LOC,+ MPTCP_SUBFLOW_ATTR_PAD,+ __MPTCP_SUBFLOW_ATTR_MAX+};++#define MPTCP_SUBFLOW_ATTR_MAX (__MPTCP_SUBFLOW_ATTR_MAX - 1)++/* netlink interface */+#define MPTCP_PM_NAME "mptcp_pm"+#define MPTCP_PM_CMD_GRP_NAME "mptcp_pm_cmds"+#define MPTCP_PM_EV_GRP_NAME "mptcp_pm_events"+#define MPTCP_PM_VER 0x1++/*+ * ATTR types defined for MPTCP+ */+enum {+ MPTCP_PM_ATTR_UNSPEC,++ MPTCP_PM_ATTR_ADDR, /* nested address */+ MPTCP_PM_ATTR_RCV_ADD_ADDRS, /* u32 */+ MPTCP_PM_ATTR_SUBFLOWS, /* u32 */++ __MPTCP_PM_ATTR_MAX+};++#define MPTCP_PM_ATTR_MAX (__MPTCP_PM_ATTR_MAX - 1)++enum {+ MPTCP_PM_ADDR_ATTR_UNSPEC,++ MPTCP_PM_ADDR_ATTR_FAMILY, /* u16 */+ MPTCP_PM_ADDR_ATTR_ID, /* u8 */+ MPTCP_PM_ADDR_ATTR_ADDR4, /* struct in_addr */+ MPTCP_PM_ADDR_ATTR_ADDR6, /* struct in6_addr */+ MPTCP_PM_ADDR_ATTR_PORT, /* u16 */+ MPTCP_PM_ADDR_ATTR_FLAGS, /* u32 */+ MPTCP_PM_ADDR_ATTR_IF_IDX, /* s32 */++ __MPTCP_PM_ADDR_ATTR_MAX+};++#define MPTCP_PM_ADDR_ATTR_MAX (__MPTCP_PM_ADDR_ATTR_MAX - 1)++#define MPTCP_PM_ADDR_FLAG_SIGNAL (1 << 0)+#define MPTCP_PM_ADDR_FLAG_SUBFLOW (1 << 1)+#define MPTCP_PM_ADDR_FLAG_BACKUP (1 << 2)+#define MPTCP_PM_ADDR_FLAG_FULLMESH (1 << 3)++enum {+ MPTCP_PM_CMD_UNSPEC,++ MPTCP_PM_CMD_ADD_ADDR,+ MPTCP_PM_CMD_DEL_ADDR,+ MPTCP_PM_CMD_GET_ADDR,+ MPTCP_PM_CMD_FLUSH_ADDRS,+ MPTCP_PM_CMD_SET_LIMITS,+ MPTCP_PM_CMD_GET_LIMITS,+ MPTCP_PM_CMD_SET_FLAGS,++ __MPTCP_PM_CMD_AFTER_LAST+};++#define MPTCP_INFO_FLAG_FALLBACK _BITUL(0)+#define MPTCP_INFO_FLAG_REMOTE_KEY_RECEIVED _BITUL(1)++/* struct mptcp_info { */+/* __u8 mptcpi_subflows; */+/* __u8 mptcpi_add_addr_signal; */+/* __u8 mptcpi_add_addr_accepted; */+/* __u8 mptcpi_subflows_max; */+/* __u8 mptcpi_add_addr_signal_max; */+/* __u8 mptcpi_add_addr_accepted_max; */+/* __u32 mptcpi_flags; */+/* __u32 mptcpi_token; */+/* __u64 mptcpi_write_seq; */+/* __u64 mptcpi_snd_una; */+/* __u64 mptcpi_rcv_nxt; */+/* __u8 mptcpi_local_addr_used; */+/* __u8 mptcpi_local_addr_max; */+/* __u8 mptcpi_csum_enabled; */+/* }; */++/*+ * MPTCP_EVENT_CREATED: token, family, saddr4 | saddr6, daddr4 | daddr6,+ * sport, dport+ * A new MPTCP connection has been created. It is the good time to allocate+ * memory and send ADD_ADDR if needed. Depending on the traffic-patterns+ * it can take a long time until the MPTCP_EVENT_ESTABLISHED is sent.+ *+ * MPTCP_EVENT_ESTABLISHED: token, family, saddr4 | saddr6, daddr4 | daddr6,+ * sport, dport+ * A MPTCP connection is established (can start new subflows).+ *+ * MPTCP_EVENT_CLOSED: token+ * A MPTCP connection has stopped.+ *+ * MPTCP_EVENT_ANNOUNCED: token, rem_id, family, daddr4 | daddr6 [, dport]+ * A new address has been announced by the peer.+ *+ * MPTCP_EVENT_REMOVED: token, rem_id+ * An address has been lost by the peer.+ *+ * MPTCP_EVENT_SUB_ESTABLISHED: token, family, saddr4 | saddr6,+ * daddr4 | daddr6, sport, dport, backup,+ * if_idx [, error]+ * A new subflow has been established. 'error' should not be set.+ *+ * MPTCP_EVENT_SUB_CLOSED: token, family, saddr4 | saddr6, daddr4 | daddr6,+ * sport, dport, backup, if_idx [, error]+ * A subflow has been closed. An error (copy of sk_err) could be set if an+ * error has been detected for this subflow.+ *+ * MPTCP_EVENT_SUB_PRIORITY: token, family, saddr4 | saddr6, daddr4 | daddr6,+ * sport, dport, backup, if_idx [, error]+ * The priority of a subflow has changed. 'error' should not be set.+ */+enum mptcp_event_type {+ MPTCP_EVENT_UNSPEC = 0,+ MPTCP_EVENT_CREATED = 1,+ MPTCP_EVENT_ESTABLISHED = 2,+ MPTCP_EVENT_CLOSED = 3,++ MPTCP_EVENT_ANNOUNCED = 6,+ MPTCP_EVENT_REMOVED = 7,++ MPTCP_EVENT_SUB_ESTABLISHED = 10,+ MPTCP_EVENT_SUB_CLOSED = 11,++ MPTCP_EVENT_SUB_PRIORITY = 13,+};++enum mptcp_event_attr {+ MPTCP_ATTR_UNSPEC = 0,++ MPTCP_ATTR_TOKEN, /* u32 */+ MPTCP_ATTR_FAMILY, /* u16 */+ MPTCP_ATTR_LOC_ID, /* u8 */+ MPTCP_ATTR_REM_ID, /* u8 */+ MPTCP_ATTR_SADDR4, /* be32 */+ MPTCP_ATTR_SADDR6, /* struct in6_addr */+ MPTCP_ATTR_DADDR4, /* be32 */+ MPTCP_ATTR_DADDR6, /* struct in6_addr */+ MPTCP_ATTR_SPORT, /* be16 */+ MPTCP_ATTR_DPORT, /* be16 */+ MPTCP_ATTR_BACKUP, /* u8 */+ MPTCP_ATTR_ERROR, /* u8 */+ MPTCP_ATTR_FLAGS, /* u16 */+ MPTCP_ATTR_TIMEOUT, /* u32 */+ MPTCP_ATTR_IF_IDX, /* s32 */+ MPTCP_ATTR_RESET_REASON,/* u32 */+ MPTCP_ATTR_RESET_FLAGS, /* u32 */++ __MPTCP_ATTR_AFTER_LAST+};++#define MPTCP_ATTR_MAX (__MPTCP_ATTR_AFTER_LAST - 1)++/* MPTCP Reset reason codes, rfc8684 */+#define MPTCP_RST_EUNSPEC 0+#define MPTCP_RST_EMPTCP 1+#define MPTCP_RST_ERESOURCE 2+#define MPTCP_RST_EPROHIBIT 3+#define MPTCP_RST_EWQ2BIG 4+#define MPTCP_RST_EBADPERF 5+#define MPTCP_RST_EMIDDLEBOX 6++/* struct mptcp_subflow_data { */+/* __u32 size_subflow_data; /1* size of this structure in userspace *1/ */+/* __u32 num_subflows; /1* must be 0, set by kernel *1/ */+/* __u32 size_kernel; /1* must be 0, set by kernel *1/ */+/* __u32 size_user; /1* size of one element in data[] *1/ */+/* } __attribute__((aligned(8))); */++/* struct mptcp_subflow_addrs { */+/* union { */+/* __kernel_sa_family_t sa_family; */+/* struct sockaddr sa_local; */+/* struct sockaddr_in sin_local; */+/* struct sockaddr_in6 sin6_local; */+/* struct __kernel_sockaddr_storage ss_local; */+/* }; */+/* union { */+/* struct sockaddr sa_remote; */+/* struct sockaddr_in sin_remote; */+/* struct sockaddr_in6 sin6_remote; */+/* struct __kernel_sockaddr_storage ss_remote; */+/* }; */+/* }; */++/* MPTCP socket options */+#define MPTCP_INFO 1+#define MPTCP_TCPINFO 2+#define MPTCP_SUBFLOW_ADDRS 3++#endif /* _UAPI_MPTCP_H */
mptcp-pm.cabal view
@@ -1,13 +1,13 @@ cabal-version: 3.0 name: mptcp-pm-version: 0.0.4+version: 0.0.5 license: GPL-3.0-only license-file: LICENSE build-type: Simple Maintainer: teto Category: Network, Mptcp Synopsis: A Multipath TCP path manager-Homepage: https://github.com/teto/netlink_pm+Homepage: https://github.com/teto/quantum2 Description: Multipath TCP (www.multipath-tcp.org) starting from version 0.95 provides a netlink path manager module. This package implements the userspace component@@ -34,33 +34,46 @@ Default: True } -Flag Dev {- Description: Relax constraints- Default: True+Flag CwndCapping {+ Description: With an experimental kernel, it's possible to cap some congestion window+ Default: False } - common shared-properties default-language: Haskell2010 ghc-options: -Wall -fno-warn-unused-binds -fno-warn-unused-matches -haddock build-depends: -- TODO remove that boundary- netlink >= 1.1.1.0+ netlink >= 1.1.1.0 , formatting , readable , polysemy+ -- winning combination+ -- co-log-0.4.0.1+ -- co-log-core-0.2.1.1+ -- co-log-polysemy-0.0.1.3+ -- integer-logarithms-1.0.3.1+ -- polysemy-log-0.3.0.2+ -- polysemy-log-co-0.3.0.2+ -- co-log-polysemy-0.0.1.3+ -- polysemy-1.7.1.0+ -- polysemy-conc-0.5.0.0+ -- polysemy-log-0.3.0.2+ -- polysemy-log-co-0.3.0.2+ -- polysemy-plugin-0.4.3.0+ -- polysemy-time-0.1.4.0+ -- >= 0.2.2.4 , polysemy-log , polysemy-log-co default-extensions:- FlexibleContexts+ FlexibleContexts , StrictData , DataKinds , FlexibleContexts , GADTs , LambdaCase- -- , OverloadedStrings , PolyKinds , RankNTypes , ScopedTypeVariables@@ -81,9 +94,14 @@ -- apparently this just helps getting a better error messages Includes: tcp_states.h- , linux/sock_diag.h- , linux/inet_diag.h- , linux/mptcp.h+ -- , linux/sock_diag.h+ -- , linux/inet_diag.h+ -- , linux/mptcp.h+ , linux/mptcp_v0.h+ -- , linux/mptcp_v1.h+ -- linux_latest.dev+ -- pass it via --extra-include-dirs=/nix/store/0l32krcbak7jw4lkwysmsg52k3m0dlm9-linux-5.15.7-dev/lib/modules/5.15.7/source/include/uapi+ -- , linux/mptcp.h -- TODO try to pass it from CLI instead , Net.TcpInfo include-dirs: headers@@ -96,6 +114,8 @@ build-depends: base >= 4.12 , containers+ , mptcp+ , lens , readable , bytestring , process@@ -121,22 +141,34 @@ c2hs:c2hs Exposed-Modules: Net.SockDiag- , Net.Tcp , Net.Bitset , Net.Tcp.Constants- , Net.Tcp.Definitions- , Net.Mptcp+ , Net.Mptcp.Types+ , Net.Mptcp.Utils , Net.Mptcp.Constants+ , Net.Mptcp.Netlink+ -- , Net.Mptcp.Fork.Constants+ -- , Net.Mptcp.Fork.Commands+ , Net.Mptcp.Upstream.Constants+ , Net.Mptcp.Upstream.Commands+ -- , Net.Mptcp.PathManager.Fork.NdiffPorts+ , Net.Mptcp.PathManager.Upstream.NdiffPorts+ -- Now implemented in Net.Mptcp.PathManager.V1.NdiffPorts, remerge later ?+ -- , Net.Mptcp.PathManager.Default , Net.Mptcp.PathManager- , Net.Mptcp.PathManager.Default , Net.IPAddress , Net.SockDiag.Constants+ , Netlink.Route -- TODO let it high level+ if flag(CwndCapping)+ cpp-options: -DEXPERIMENTAL_CWND=1 + ghc-options:+ -Werror=missing-home-modules -- monitor new mptcp connections -- and delegate the behavior to a monitor-executable mptcp-manager+executable mptcp-pm import: shared-properties default-language: Haskell2010 build-depends:@@ -146,11 +178,11 @@ , base >= 4.12 && < 4.17 , bytestring , containers+ , lens+ , mptcp , mptcp-pm , optparse-applicative , transformers- -- , fast-logger- -- , hslogger , ip , text , mtl@@ -158,6 +190,7 @@ , process , temporary , filepath+ , pretty-simple -- to use Simple module. Try to do without , netlink >= 1.1.1.0 default-extensions: DeriveGeneric@@ -169,11 +202,13 @@ Test-Suite test-tcp -- 2 types supported, exitcode is based on ... exit codes .... type: exitcode-stdio-1.0- default-language: Haskell2010+ default-language: Haskell2010 main-is: Main.hs hs-source-dirs: test- ghc-options: -threaded -rtsopts- build-depends: base >=4.12- , HUnit- , mptcp-pm- , ip, text+ ghc-options: -threaded -rtsopts+ build-depends:+ base >=4.12+ , HUnit+ , mptcp+ , mptcp-pm+ , ip, text
− src/Net/Mptcp.hs
@@ -1,486 +0,0 @@-{-|-Module : Net.Mptcp-Description : Implementation of mptcp netlink path manager-Maintainer : matt-Stability : testing-Portability : Linux--OverloadedStrings allows Aeson to convert--}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-module Net.Mptcp (- -- * Types- MptcpConnection (..)- , MptcpPacket- , MptcpSocket (..)- , MptcpToken- , dumpAttribute- , mptcpConnAddSubflow- , mptcpConnRemoveSubflow- , newSubflowPkt- , capCwndPkt- , subflowFromAttributes- , readToken- , remoteIdFromAttributes-)-where--import Control.Exception (assert)-import Net.SockDiag ()--import qualified Data.Map as Map-import Data.Word (Word16, Word32, Word8)-import System.Linux.Netlink hiding (makeSocket)--- import System.Linux.Netlink (query, Packet(..))-import System.Linux.Netlink.Constants-import System.Linux.Netlink.GeNetlink--- import System.Linux.Netlink.GeNetlink.Control-import Data.ByteString (ByteString)-import Data.Maybe (fromJust)--import Data.Serialize.Get-import Data.Serialize.Put--import Data.Bits ((.|.))--import Control.Concurrent ()-import Control.Monad.Trans.State ()-import Data.Aeson-import Data.List ()-import qualified Data.Set as Set-import Debug.Trace-import GHC.Generics-import Net.IP-import Net.IPAddress-import Net.IPv4-import Net.IPv6-import Net.Mptcp.Constants-import Net.Tcp--data MptcpSocket = MptcpSocket NetlinkSocket Word16-instance Show MptcpSocket where- show sock = let (MptcpSocket _ fid) = sock in ("Mptcp netlink socket: " ++ show fid)--type MptcpPacket = GenlPacket NoData---- |Same as SockDiagMetrics--- data SubflowWithMetrics = SubflowWithMetrics {--- subflowSubflow :: TcpConnection--- -- for now let's retain DiagTcpInfo only--- , metrics :: [SockDiagExtension]--- }---- |Holds MPTCP level information-data MptcpConnection = MptcpConnection {- connectionToken :: MptcpToken- -- use SubflowWithMetrics instead ?!- -- , subflows :: Set.Set [TcpConnection]- , subflows :: Set.Set TcpConnection- , localIds :: Set.Set Word8 -- ^ Announced addresses- , remoteIds :: Set.Set Word8 -- ^ Announced addresses-- -- Might be reworked/moved in an Enriched/Tracker structure afterwards- , get_caps_prog :: Maybe FilePath-} deriving (Show, Generic)---- | Remote port-data RemoteId = RemoteId {-- remoteAddress :: IP- , remotePort :: Word16-}----remoteIdFromAttributes :: Attributes -> RemoteId-remoteIdFromAttributes attrs = let- (SubflowDestPort dport) = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_DPORT attrs- -- (SubflowFamily _) = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_FAMILY attrs- SubflowDestAddress destIp = ipFromAttributes False attrs-- -- (SubflowDestPort dport) = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_DPORT attrs- in- RemoteId destIp dport---- we don't really care-instance FromJSON MptcpConnection---- | export to the format expected by mptcpnumerics--- could be automatically generated ?--- toJSON :: MptcpConnection -> Value-instance ToJSON MptcpConnection where- toJSON mptcpConn = object- [ "name" .= toJSON (show $ connectionToken mptcpConn)- , "sender" .= object [- -- TODO here we could read from sysctl ? or use another SockDiagExtension- "snd_buffer" .= toJSON (40 :: Int)- , "capabilities" .= object []- ]- , "capabilities" .= object ([])- -- TODO generated somewhere else- -- , "subflows" .= object ([])- ]----- |Adds a subflow to the connection--- TODO compose with mptcpConnAddLocalId-mptcpConnAddSubflow :: MptcpConnection -> TcpConnection -> MptcpConnection-mptcpConnAddSubflow mptcpConn sf =- -- trace ("Adding subflow" ++ show sf)- mptcpConnAddLocalId- (mptcpConnAddRemoteId- (mptcpConn { subflows = Set.insert sf (subflows mptcpConn) })- (remoteId sf)- )- (localId sf)-- -- , localIds = Set.insert (localId sf) (localIds mptcpConn)- -- , remoteIds = Set.insert (remoteId sf) (remoteIds mptcpConn)- -- }----- |Add local id-mptcpConnAddLocalId :: MptcpConnection- -> Word8 -- ^Local id to add- -> MptcpConnection-mptcpConnAddLocalId con locId = con { localIds = Set.insert (locId) (localIds con) }----- |Add remote id-mptcpConnAddRemoteId :: MptcpConnection- -> Word8 -- ^Remote id to add- -> MptcpConnection-mptcpConnAddRemoteId con remId = con { localIds = Set.insert (remId) (remoteIds con) }---- |Remove subflow from an MPTCP connection-mptcpConnRemoveSubflow :: MptcpConnection -> TcpConnection -> MptcpConnection-mptcpConnRemoveSubflow con sf = con {- subflows = Set.delete sf (subflows con)- -- TODO remove associated local/remote Id ?-}---getPort :: ByteString -> Word16-getPort val =- case (runGet getWord16host val) of- Left _ -> 0- Right port -> port-------- The message type/ flag / sequence number / pid (0 => from the kernel)--- https://elixir.bootlin.com/linux/latest/source/include/uapi/linux/netlink.h#L54-fixHeader :: MptcpSocket -> Bool -> MptcpPacket -> MptcpPacket-fixHeader _ dump pkt = let- myHeader = Header 0 (flags .|. fNLM_F_ACK) 0 0- flags = if dump then fNLM_F_REQUEST .|. fNLM_F_MATCH .|. fNLM_F_ROOT else fNLM_F_REQUEST- in- pkt { packetHeader = myHeader }---{-|- Generates an Mptcp netlink request-TODO we could fake the Word16/Flag and--}-genMptcpRequest :: Word16 -- ^the family id- -> MptcpGenlEvent -- ^The MPTCP command- -> Bool -- ^Dump answer (returns EOPNOTSUPP if not possible)- -- -> Attributes- -> [MptcpAttribute]- -> MptcpPacket-genMptcpRequest fid cmd dump attrs =- let- myHeader = Header (fromIntegral fid) (flags .|. fNLM_F_ACK) 0 0- geheader = GenlHeader word8Cmd mptcpGenlVer- flags = if dump then fNLM_F_REQUEST .|. fNLM_F_MATCH .|. fNLM_F_ROOT else fNLM_F_REQUEST- word8Cmd = fromIntegral (fromEnum cmd) :: Word8-- pkt = Packet myHeader (GenlData geheader NoData) (mptcpListToAttributes attrs)- -- TODO run an assert on the list filter- hasTokenAttr = Prelude.any (isAttribute (MptcpAttrToken 0)) attrs- in- assert hasTokenAttr pkt---- | TODO change / return Either-readToken :: ByteString -> Either String MptcpToken-readToken val = runGet getWord32host val---- LocId => Word8-readLocId :: Maybe ByteString -> LocId-readLocId maybeVal = case maybeVal of- Nothing -> error "Missing locator id"- Just val -> case runGet getWord8 val of- -- TODO generate an error here !- Left _ -> error "Could not get locId !!"- Right locId -> locId- -- runGet getWord8 val---- doDumpLoop :: MyState -> IO MyState--- doDumpLoop myState = do--- let (MptcpSocket simpleSock fid) = socket myState--- results <- recvOne' simpleSock :: IO [Either String MptcpPacket]--- -- TODO retrieve packets--- mapM_ (inspectResult myState) results--- newState <- doDumpLoop myState--- return newState----- data MptcpAttributes = MptcpAttributes {--- connToken :: Word32--- , localLocatorID :: Maybe Word8--- , remoteLocatorID :: Maybe Word8--- , family :: Word16 -- Remove ?--- -- |Pointer to the Attributes map used to build this struct. This is purely--- -- |for forward compat, please file a feature report if you have to use this.--- , staSelf :: Attributes--- } deriving (Show, Eq, Read)---- Wouldn't it be easier to work with ?--- data MptcpEvent = NewConnection {--- }----- |Represents every possible setting sent/received on the netlink channel-data MptcpAttribute =- MptcpAttrToken MptcpToken |- -- v4 or v6, AddressFamily is a netlink def- SubflowFamily AddressFamily | -- ^ should be Word16 too- -- remote/local ?- RemoteLocatorId Word8 |- LocalLocatorId Word8 |- SubflowSourceAddress IP |- SubflowDestAddress IP |- SubflowSourcePort Word16 |- SubflowDestPort Word16 |- SubflowMaxCwnd Word32 |- SubflowBackup Word8 |- SubflowInterface Word32- deriving (Show, Eq)--type MptcpToken = Word32-type LocId = Word8---- inspired by netlink cATA :: CtrlAttribute -> (Int, ByteString)-attrToPair :: MptcpAttribute -> (Int, ByteString)-attrToPair (MptcpAttrToken token) = (fromEnum MPTCP_ATTR_TOKEN, runPut $ putWord32host token)-attrToPair (RemoteLocatorId loc) = (fromEnum MPTCP_ATTR_REM_ID, runPut $ putWord8 loc)-attrToPair (LocalLocatorId loc) = (fromEnum MPTCP_ATTR_LOC_ID, runPut $ putWord8 loc)-attrToPair (SubflowFamily fam) = let- fam8 = (fromIntegral $ fromEnum fam) :: Word16- in (fromEnum MPTCP_ATTR_FAMILY, runPut $ putWord16host fam8)--attrToPair ( SubflowInterface idx) = (fromEnum MPTCP_ATTR_IF_IDX, runPut $ putWord32host idx)-attrToPair ( SubflowSourcePort port) = (fromEnum MPTCP_ATTR_SPORT, runPut $ putWord16host port)-attrToPair ( SubflowDestPort port) = (fromEnum MPTCP_ATTR_DPORT, runPut $ putWord16host port)-attrToPair ( SubflowMaxCwnd limit) = (fromEnum MPTCP_ATTR_CWND, runPut $ putWord32host limit)-attrToPair ( SubflowBackup prio) = (fromEnum MPTCP_ATTR_BACKUP, runPut $ putWord8 prio)--- TODO should depend on the ip putWord32be w32-attrToPair ( SubflowSourceAddress addr) =- case_ (genV4SubflowAddress MPTCP_ATTR_SADDR4) (genV6SubflowAddress MPTCP_ATTR_SADDR6) addr-attrToPair ( SubflowDestAddress addr) =- case_ (genV4SubflowAddress MPTCP_ATTR_DADDR4) (genV6SubflowAddress MPTCP_ATTR_DADDR6) addr---genV4SubflowAddress :: MptcpAttr -> IPv4 -> (Int, ByteString)-genV4SubflowAddress attr ip = (fromEnum attr, runPut $ putWord32be w32)- where- w32 = getIPv4 ip--genV6SubflowAddress :: MptcpAttr -> IPv6 -> (Int, ByteString)-genV6SubflowAddress _addr = undefined--mptcpListToAttributes :: [MptcpAttribute] -> Attributes-mptcpListToAttributes attrs = Map.fromList $Prelude.map attrToPair attrs----- |Retreive IP--- TODO could check/use addressfamily as well-ipFromAttributes :: Bool -- ^True if source- -> Attributes -> MptcpAttribute-ipFromAttributes True attrs =- case makeAttributeFromMaybe MPTCP_ATTR_SADDR4 attrs of- Just ip -> ip- Nothing -> case makeAttributeFromMaybe MPTCP_ATTR_SADDR6 attrs of- Just ip -> ip- Nothing -> error "could not get the src IP"--ipFromAttributes False attrs =- case makeAttributeFromMaybe MPTCP_ATTR_DADDR4 attrs of- Just ip -> ip- Nothing -> case makeAttributeFromMaybe MPTCP_ATTR_DADDR6 attrs of- Just ip -> ip- Nothing -> error "could not get dest IP"---- mptcpAttributesToMap :: [MptcpAttribute] -> Attributes--- mptcpAttributesToMap attrs =--- Map.fromList $map mptcpAttributeToTuple attrs---- |Converts / should be a maybe ?--- TODO simplify-subflowFromAttributes :: Attributes -> TcpConnection-subflowFromAttributes attrs =- let- -- expects a ByteString- SubflowSourcePort sport = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_SPORT attrs- SubflowDestPort dport = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_DPORT attrs- SubflowSourceAddress _srcIp = ipFromAttributes True attrs- SubflowDestAddress _dstIp = ipFromAttributes False attrs- LocalLocatorId lid = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_LOC_ID attrs- RemoteLocatorId rid = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_REM_ID attrs- SubflowInterface intfId = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_IF_IDX attrs- -- sfFamily = getPort $ fromJust (Map.lookup (fromEnum MPTCP_ATTR_FAMILY) attrs)- prio = Nothing -- (SubflowPriority N)- in- -- TODO fix sfFamily- TcpConnection _srcIp _dstIp sport dport prio lid rid (Just intfId)----- TODO prefix with 'e' for enum--- Map.lookup (fromEnum attr) m--- getAttribute :: MptcpAttr -> Attributes -> Maybe MptcpAttribute--- getAttribute attr m--- | attr == MPTCP_ATTR_TOKEN = Nothing--- | otherwise = Nothing---- getAttribute :: (Int, ByteString) -> CtrlAttribute--- getAttribute (i, x) = fromMaybe (CTRL_ATTR_UNKNOWN i x) $makeAttribute i x---- getW16 :: ByteString -> Maybe Word16--- getW16 x = e2M (runGet g16 x)---- getW32 :: ByteString -> Maybe Word32--- getW32 x = e2M (runGet g32 x)---- "either2Maybe"-e2M :: Either a b -> Maybe b-e2M (Right x) = Just x-e2M _ = Nothing--convertAttributesIntoMap :: Attributes -> Map.Map MptcpAttr MptcpAttribute-convertAttributesIntoMap attrs = let- customFn k val = fromJust (makeAttribute k val)- newMap = Map.mapWithKey (customFn) attrs- in- Map.mapKeys (toEnum) newMap---- TODO rename fromMap-makeAttributeFromMaybe :: MptcpAttr -> Attributes -> Maybe MptcpAttribute-makeAttributeFromMaybe attrType attrs =- let res = Map.lookup (fromEnum attrType) attrs in- case res of- Nothing -> error $ "Could not build attr " ++ show attrType- Just bytestring -> makeAttribute (fromEnum attrType) bytestring---- | Builds an MptcpAttribute from-makeAttribute :: Int -- ^ MPTCP_ATTR_TOKEN value- -> ByteString- -> Maybe MptcpAttribute-makeAttribute i val =- case toEnum i of- MPTCP_ATTR_TOKEN ->- case readToken val of- Left err -> error "could not decode"- Right mptcpToken -> Just $ MptcpAttrToken mptcpToken-- -- TODO fix- MPTCP_ATTR_FAMILY ->- case runGet getWord16host val of- -- assert it's eAF_INET or eAF_INET6- Right x -> Just $ SubflowFamily (toEnum ( fromIntegral x :: Int))- _ -> Nothing- MPTCP_ATTR_SADDR4 -> SubflowSourceAddress <$> fromIPv4 <$> e2M ( getIPv4FromByteString val)- MPTCP_ATTR_DADDR4 -> SubflowDestAddress <$> fromIPv4 <$> e2M (getIPv4FromByteString val)- MPTCP_ATTR_SADDR6 -> SubflowSourceAddress <$> fromIPv6 <$> e2M (getIPv6FromByteString val)- MPTCP_ATTR_DADDR6 -> SubflowDestAddress <$> fromIPv6 <$> e2M (getIPv6FromByteString val)- MPTCP_ATTR_SPORT -> SubflowSourcePort <$> port where port = e2M $ runGet getWord16host val- MPTCP_ATTR_DPORT -> SubflowDestPort <$> port where port = e2M $ runGet getWord16host val- MPTCP_ATTR_LOC_ID -> Just (LocalLocatorId $ readLocId $ Just val )- MPTCP_ATTR_REM_ID -> Just (RemoteLocatorId $ readLocId $ Just val )- MPTCP_ATTR_IF_IDX -> trace ("if_idx: " ++ show val) (- case runGet getWord32be val of- Right x -> Just $ SubflowInterface x- _ -> Nothing)- -- backup is u8- MPTCP_ATTR_BACKUP -> Just (SubflowBackup $ readLocId $ Just val )- MPTCP_ATTR_ERROR -> trace "makeAttribute ERROR" Nothing- MPTCP_ATTR_TIMEOUT -> undefined- MPTCP_ATTR_CWND -> undefined- MPTCP_ATTR_FLAGS -> trace "makeAttribute ATTR_FLAGS" Nothing- MPTCP_ATTR_UNSPEC -> undefined---dumpAttribute :: Int -> ByteString -> String-dumpAttribute attrId value =- show $ makeAttribute attrId value--checkIfSocketExistsPkt :: Word16 -> [MptcpAttribute] -> MptcpPacket-checkIfSocketExistsPkt fid attributes =- genMptcpRequest fid MPTCP_CMD_EXIST True attributes---- https://stackoverflow.com/questions/47861648/a-general-way-of-comparing-constructors-of-two-terms-in-haskell?noredirect=1&lq=1--- attrToPair ( SubflowSourcePort port) = (fromEnum MPTCP_ATTR_SPORT, runPut $ putWord8 loc)-isAttribute :: MptcpAttribute -- ^ to compare with- -> MptcpAttribute -- ^to compare to- -> Bool-isAttribute ref toCompare = fst (attrToPair toCompare) == fst (attrToPair ref)---- create a fake LocalLocatorId-hasLocAddr :: [MptcpAttribute] -> Bool-hasLocAddr attrs = Prelude.any (isAttribute (LocalLocatorId 0)) attrs--hasFamily :: [MptcpAttribute] -> Bool-hasFamily = Prelude.any (isAttribute (SubflowFamily eAF_INET))---- need to prepare a request--- type GenlPacket a = Packet (GenlData a)--- REQUIRES: LOC_ID / TOKEN--- TODO pass TcpConnection-resetConnectionPkt :: MptcpSocket -> [MptcpAttribute] -> MptcpPacket-resetConnectionPkt (MptcpSocket _sock fid) attrs = let- _cmd = MPTCP_CMD_REMOVE- in- assert (hasLocAddr attrs) $ genMptcpRequest fid MPTCP_CMD_REMOVE False attrs----- pass token ?-subflowAttrs :: TcpConnection -> [MptcpAttribute]-subflowAttrs con = [- LocalLocatorId $ localId con- , RemoteLocatorId $ remoteId con- , SubflowFamily $ getAddressFamily (dstIp con)- , SubflowDestAddress $ dstIp con- , SubflowDestPort $ dstPort con- -- should fail if doesn't exist- , SubflowInterface $ fromJust $ subflowInterface con- -- https://github.com/multipath-tcp/mptcp/issues/338- , SubflowSourceAddress $ srcIp con- , SubflowSourcePort $ srcPort con- ]---- |Generate a request to create a new subflow-capCwndPkt :: MptcpSocket -> MptcpConnection- -> Word32 -- ^Limit to apply to congestion window- -> TcpConnection -> MptcpPacket-capCwndPkt (MptcpSocket _ fid) mptcpCon limit sf =- assert (hasFamily attrs) pkt- where- oldPkt = genMptcpRequest fid MPTCP_CMD_SND_CLAMP_WINDOW False attrs- pkt = oldPkt { packetHeader = (packetHeader oldPkt) { messagePID = 42 } }- attrs = connectionAttrs mptcpCon- ++ [ SubflowMaxCwnd limit ]- ++ subflowAttrs sf---connectionAttrs :: MptcpConnection -> [MptcpAttribute]-connectionAttrs con = [ MptcpAttrToken $ connectionToken con ]---- sport/backup/intf are optional-newSubflowPkt :: MptcpSocket -> MptcpConnection -> TcpConnection -> MptcpPacket-newSubflowPkt (MptcpSocket _ fid) mptcpCon sf = let- _cmd = MPTCP_CMD_SUB_CREATE- attrs = connectionAttrs mptcpCon ++ subflowAttrs sf- pkt = genMptcpRequest fid MPTCP_CMD_SUB_CREATE False attrs- in- assert (hasFamily attrs) pkt-
− src/Net/Mptcp/Constants.chs
@@ -1,50 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-{-|-Module : Net.Mptcp.Constants-Description : A module to bridge the haskell code to underlying C code--I consider this module internal.-The documentation may be a bit sparse.-Inspired by:-https://stackoverflow.com/questions/6689969/how-does-one-interface-with-a-c-enum-using-haskell-and-ffi--TODO might be best to just use the netlink script and adapt it-https://github.com/Ongy/netlink-hs/issues/7--}-module Net.Mptcp.Constants (- MptcpAttr(..)- , MptcpGenlEvent(..)-- , mptcpGenlVer- , mptcpGenlName- , mptcpGenlCmdGrpName- , mptcpGenlEvGrpName-)-where--import Data.Word (Word8)--- import System.Linux.Netlink.Constants (MessageType)-import Data.Bits ()---- from include/uapi/linux/mptcp.h-#include <linux/mptcp.h>---- {underscoreToCase}--- add prefix = "e"-{#enum MPTCP_ATTR_UNSPEC as MptcpAttr {} omit (__MPTCP_ATTR_AFTER_LAST) deriving (Eq, Show, Ord)#}---- {underscoreToCase}--- can also be seen as a command-{#enum MPTCP_CMD_UNSPEC as MptcpGenlEvent {} deriving (Eq, Show)#}---- |Generic netlink MPTCP version-mptcpGenlVer :: Word8-mptcpGenlVer = {#const MPTCP_GENL_VER #}--mptcpGenlName :: String-mptcpGenlName = {#const MPTCP_GENL_NAME #}-mptcpGenlCmdGrpName :: String-mptcpGenlCmdGrpName = {#const MPTCP_GENL_CMD_GRP_NAME #}-mptcpGenlEvGrpName :: String-mptcpGenlEvGrpName = {#const MPTCP_GENL_EV_GRP_NAME #}-
+ src/Net/Mptcp/Constants.hs view
@@ -0,0 +1,5 @@+module Net.Mptcp.Constants (+ module C+) where+import Net.Mptcp.Upstream.Constants as C+
+ src/Net/Mptcp/Netlink.hs view
@@ -0,0 +1,52 @@+module Net.Mptcp.Netlink+where++import System.Linux.Netlink.Constants+import System.Linux.Netlink.GeNetlink++import Data.Word (Word8, Word16, Word32)+import System.Linux.Netlink+-- import System.Linux.Netlink.Constants+import Net.IP+-- import Net.Mptcp.Types+-- import Net.Mptcp.Constants+import Data.Bits ((.|.))+-- import qualified Data.Map as Map++data MptcpSocket = MptcpSocket NetlinkSocket Word16++-- |Represents every possible setting sent/received on the netlink channel+data MptcpAttribute =+ MptcpAttrToken Word32 |+ -- v4 or v6, AddressFamily is a netlink def+ SubflowFamily AddressFamily | -- ^ should be Word16 too+ -- remote/local ?+ RemoteLocatorId Word8 |+ LocalLocatorId Word8 |+ SubflowSourceAddress IP |+ SubflowDestAddress IP |+ SubflowSourcePort Word16 |+ SubflowDestPort Word16 |+ SubflowMaxCwnd Word32 |+ SubflowBackup Word8 |+ SubflowInterface Word32+ deriving (Show, Eq)+++-- instance Show MptcpSocket where+--+showMptcpSocket :: MptcpSocket -> String+showMptcpSocket (MptcpSocket _ fid) = "Mptcp netlink socket: " ++ show fid++type MptcpPacket = GenlPacket NoData+++--+-- The message type/ flag / sequence number / pid (0 => from the kernel)+-- https://elixir.bootlin.com/linux/latest/source/include/uapi/linux/netlink.h#L54+fixHeader :: MptcpSocket -> Bool -> MptcpPacket -> MptcpPacket+fixHeader _ dump pkt = let+ myHeader = Header 0 (flags .|. fNLM_F_ACK) 0 0+ flags = if dump then fNLM_F_REQUEST .|. fNLM_F_MATCH .|. fNLM_F_ROOT else fNLM_F_REQUEST+ in+ pkt { packetHeader = myHeader }
src/Net/Mptcp/PathManager.hs view
@@ -4,7 +4,7 @@ Maintainer : matt Portability : Linux -Trying to come up with a userspace abstraction for MPTCP path management+Userspace abstractions for MPTCP path management -} @@ -12,9 +12,9 @@ module Net.Mptcp.PathManager ( PathManager (..) , NetworkInterface(..)- , AvailablePaths+ , ExistingInterfaces , PathManagerConfig- , loadConnectionsFromFile+ -- , loadConnectionsFromFile , mapIPtoInterfaceIdx , defaultPathManagerConfig -- TODO don't export / move to its own file@@ -25,13 +25,16 @@ import Prelude hiding (concat, init) import Control.Concurrent-import Data.Aeson import qualified Data.Map as Map import Data.Word (Word32) import Debug.Trace import Net.IP import Net.Mptcp-import Net.Tcp+-- import Net.Tcp+import Net.Mptcp.Netlink+import Net.IPAddress++-- hackage import System.Linux.Netlink as NL import qualified System.Linux.Netlink.Route as NLR -- import System.Linux.Netlink.Constants (eRTM_NEWADDR)@@ -39,13 +42,12 @@ -- import qualified System.Linux.Netlink.Simple as NLS import Data.ByteString (ByteString, empty) import Data.ByteString.Char8 (init, unpack)-import qualified Data.ByteString.Lazy as BL import Data.Maybe (fromMaybe)-import Net.IPAddress import System.IO.Unsafe+-- import Data.Aeson {-# NOINLINE globalInterfaces #-}-globalInterfaces :: MVar AvailablePaths+globalInterfaces :: MVar ExistingInterfaces globalInterfaces = unsafePerformIO newEmptyMVar @@ -60,11 +62,12 @@ interfacesToIgnore :: [String] interfacesToIgnore = [- "virbr0"+ "virbr0" , "virbr1"+ , "docker0" , "nlmon0"- , "ppp0"- , "lo"+ -- , "ppp0"+ -- , "lo" ] -- basically a retranscription of NLR.NAddrMsg@@ -76,34 +79,36 @@ -- [NetworkInterface]-type AvailablePaths = Map.Map IP NetworkInterface+type ExistingInterfaces = Map.Map IP NetworkInterface -- |-mapIPtoInterfaceIdx :: AvailablePaths -> IP -> Maybe Word32+mapIPtoInterfaceIdx :: ExistingInterfaces -> IP -> Maybe Word32 mapIPtoInterfaceIdx paths ip = interfaceId <$> Map.lookup ip paths -- class AvailableIPsContainer a where -- | Load a list of connections from a json file-loadConnectionsFromFile :: FilePath -> IO [TcpConnection]-loadConnectionsFromFile filename = do- -- Log.info ("Loading connections whitelist from " <> tshow filename <> "...")- filteredConnectionsStr <- BL.readFile filename- case Data.Aeson.eitherDecode filteredConnectionsStr of- Left errMsg -> error ("Failed loading " ++ filename ++ ":\n" ++ errMsg)- Right list -> return list+-- loadConnectionsFromFile :: FilePath -> IO [TcpConnection]+-- loadConnectionsFromFile filename = do+-- -- Log.info ("Loading connections whitelist from " <> tshow filename <> "...")+-- filteredConnectionsStr <- BL.readFile filename+-- case Data.Aeson.eitherDecode filteredConnectionsStr of+-- Left errMsg -> error ("Failed loading " ++ filename ++ ":\n" ++ errMsg)+-- Right list -> return list -- |Reimplements -- TODO we should not need the socket -- onMasterEstablishement data PathManager = PathManager {- name :: String+ name :: String -- interfacesToIgnore :: [String]- , onMasterEstablishement :: MptcpSocket -> MptcpConnection -> AvailablePaths -> [MptcpPacket]+ , onMasterEstablishement :: MptcpSocket -> MptcpConnection -> ExistingInterfaces -> [MptcpPacket]+ -- , idManager ::+ -- ^ to keep track of advertised/present ids/generate new ones } -- } deriving PathManager@@ -118,18 +123,18 @@ -- eno1: <BROADCAST,MULTICAST,UP,LOWER_UP case ifNameM of Nothing -> Nothing- Just ifName -> case (elem ifName interfacesToIgnore ) of+ Just ifName -> case (elem ifName interfacesToIgnore) of True -> Nothing False -> Just $ NetworkInterface ip ifName addrIntf where -- gets the bytestring / assume it always work- ipBstr = fromMaybe empty (NLR.getIFAddr attrs)- ifNameBstr = (Map.lookup NLC.eIFLA_IFNAME attrs)- ifNameM = getString <$> ifNameBstr- -- ip = getIPFromByteString addrFamily ipBstr- ip = case (getIPFromByteString addrFamily ipBstr) of- Right val -> val- Left err -> undefined+ ipBstr = fromMaybe empty (NLR.getIFAddr attrs)+ ifNameBstr = (Map.lookup NLC.eIFLA_IFNAME attrs)+ ifNameM = getString <$> ifNameBstr+ -- ip = getIPFromByteString addrFamily ipBstr+ ip = case (getIPFromByteString addrFamily ipBstr) of+ Right val -> val+ Left err -> undefined -- taken from netlink getString :: ByteString -> String@@ -138,7 +143,7 @@ -- TODO handle remove/new event move to PathManager -- todo should be pure and let daemon-handleAddr :: PathManagerConfig -> Either String NLR.RoutePacket -> IO ()+handleAddr :: [String] -> Either String NLR.RoutePacket -> IO () handleAddr _ (Left errStr) = putStrLn $ "Error decoding packet: " ++ errStr handleAddr _ (Right (DoneMsg hdr)) = putStrLn $ "Error decoding packet: " ++ show hdr handleAddr _ (Right (ErrorMsg hdr errorInt errorBstr)) = putStrLn $ "Error decoding packet: " ++ show hdr@@ -152,20 +157,21 @@ arg@NLR.NAddrMsg{} -> let resIntf = handleInterfaceNotification (NLR.addrFamily arg) attrs (NLR.addrInterfaceIndex arg) in case resIntf of- Nothing -> oldIntfs- Just newIntf -> let- ip = ipAddress newIntf- in if msgType == eRTM_NEWADDR- then trace "adding ip" (Map.insert ip newIntf oldIntfs)- -- >> putStrLn "Added interface"- else if msgType == eRTM_GETADDR- then trace "GET_ADDR" oldIntfs+ Nothing -> oldIntfs+ Just newIntf -> let+ ip = ipAddress newIntf+ -- todo use cae ?+ in if msgType == eRTM_NEWADDR+ then trace "adding ip" (Map.insert ip newIntf oldIntfs)+ -- >> putStrLn "Added interface"+ else if msgType == eRTM_GETADDR+ then trace "GET_ADDR" oldIntfs - else if msgType == eRTM_DELADDR- then- trace "deleting ip" (Map.delete ip oldIntfs)- -- >> putStrLn "Removed interface"- else trace "other type" oldIntfs+ else if msgType == eRTM_DELADDR+ then+ trace "deleting ip" (Map.delete ip oldIntfs)+ -- >> putStrLn "Removed interface"+ else trace "other type" oldIntfs -- _ -> error "can't be anything else" arg@NLR.NNeighMsg{} -> trace "neighbor msg" oldIntfs
− src/Net/Mptcp/PathManager/Default.hs
@@ -1,79 +0,0 @@-{-|-Description : Implementation of mptcp netlink path manager-module: Net.Mptcp.PathManager.Default-Maintainer : matt-Portability : Linux--}-module Net.Mptcp.PathManager.Default (- -- TODO don't export / move to its own file- ndiffports- , meshPathManager-) where--import Data.Maybe (fromJust)-import qualified Data.Set as Set-import Debug.Trace-import Net.Mptcp-import Net.Mptcp.PathManager-import Net.Tcp---- | Opens several subflows on each interface-ndiffports :: PathManager-ndiffports = PathManager {- name = "ndiffports"- , onMasterEstablishement = nportsOnMasterEstablishement-}---- | Creates a subflow between each pair of (client, server) interfaces-meshPathManager :: PathManager-meshPathManager = PathManager {- name = "mesh"- , onMasterEstablishement = meshOnMasterEstablishement-}------ per interface--- TODO check if there is already an interface with this connection-meshGenPkt :: MptcpSocket -> MptcpConnection -> NetworkInterface -> [MptcpPacket] -> [MptcpPacket]-meshGenPkt mptcpSock mptcpCon intf pkts =-- if traceShow (intf) (interfaceId intf == (fromJust $ subflowInterface masterSf)) then- pkts- else- pkts ++ [newSubflowPkt mptcpSock mptcpCon generatedCon]- where- generatedCon = TcpConnection {- srcPort = 0 -- let the kernel handle it- , dstPort = dstPort masterSf- , srcIp = ipAddress intf- , dstIp = dstIp masterSf -- same as master- , priority = Nothing- -- TODO fix this- , localId = fromIntegral $ interfaceId intf -- how to get it ? or do I generate it ?- , remoteId = remoteId masterSf- , subflowInterface = Just $ interfaceId intf- }-- masterSf = Set.elemAt 0 (subflows mptcpCon)---{-- Generate requests-it iterates over local interfaces and try to connect--}-meshOnMasterEstablishement :: MptcpSocket -> MptcpConnection -> AvailablePaths -> [MptcpPacket]-meshOnMasterEstablishement mptcpSock con paths = do- foldr (meshGenPkt mptcpSock con) [] paths---{-- Generate requests-TODO it iterates over local interfaces but not--}-nportsOnMasterEstablishement :: MptcpSocket -> MptcpConnection -> AvailablePaths -> [MptcpPacket]-nportsOnMasterEstablishement mptcpSock con paths = do- foldr (meshGenPkt mptcpSock con) [] paths- -- TODO create #X subflows- -- iterate-
+ src/Net/Mptcp/PathManager/Upstream/NdiffPorts.hs view
@@ -0,0 +1,99 @@+{-|+Description : Implementation of mptcp netlink path manager+module: Net.Mptcp.PathManager.V1.NdiffPorts+Maintainer : matt+Portability : Linux+-}+module Net.Mptcp.PathManager.Upstream.NdiffPorts (+ -- TODO don't export / move to its own file+ ndiffports+ , meshPathManager+ , nportsOnMasterEstablishement+) where++import Data.Maybe (fromJust)+-- import qualified Data.Set as Set+import Debug.Trace+import Net.Mptcp+import Net.Stream+import Net.Mptcp.PathManager+-- import Net.Mptcp.Types+import Net.Tcp.Connection+import Net.Mptcp.Upstream.Commands+import Net.Mptcp.Netlink+++-- These should be plugins++ndiffports :: PathManager+ndiffports = PathManager {+ name = "ndiffports"+ , onMasterEstablishement = nportsOnMasterEstablishement+}++{-+ Generate requests+TODO it iterates over local interfaces but not+-}+nportsOnMasterEstablishement :: MptcpSocket -> MptcpConnection -> ExistingInterfaces -> [MptcpPacket]+nportsOnMasterEstablishement mptcpSock mptcpCon paths = do+ map (newSublowPacketFromPort ) [3456]+ where+ generatedCon port = let+ master = fromJust (getMasterSubflow mptcpCon)+ in+ master { sfConn = (sfConn master) { conTcpClientPort = port } }+ newSublowPacketFromPort port = newSubflowPkt mptcpSock mptcpCon (generatedCon port)++ -- TODO create #X subflows+ -- iterate++-- | Creates a subflow between each pair of (client, server) interfaces+meshPathManager :: PathManager+meshPathManager = PathManager {+ name = "mesh"+ , onMasterEstablishement = meshOnMasterEstablishement+}++++-- per interface+-- TODO check if there is already an interface with this connection+meshGenPkt :: MptcpSocket -> MptcpConnection -> NetworkInterface -> [MptcpPacket] -> [MptcpPacket]+meshGenPkt mptcpSock mptcpCon intf pkts =++ if traceShow (intf) (interfaceId intf == (fromJust $ sfInterface masterSf)) then+ pkts+ else+ pkts ++ [newSubflowPkt mptcpSock mptcpCon generatedSf]+ where+ generatedSf = MptcpSubflow {+ sfConn = generatedCon+ , sfJoinToken = Nothing+ , sfPriority = Nothing+ -- TODO fix this+ , sfLocalId = fromIntegral $ interfaceId intf -- how to get it ? or do I generate it ?+ , sfRemoteId = sfRemoteId masterSf+ , sfInterface = Just $ interfaceId intf+ }+ generatedCon = (sfConn masterSf) {+ conTcpClientPort = 0 -- let the kernel handle it+ -- , conTcpServerPort = (conTcpServerPort . sfConn) masterSf+ , conTcpClientIp = ipAddress intf+ -- , conTcpServerIp = (conTcpServerIp . sfConn) masterSf -- same as master+ , conTcpStreamId = StreamId 0+ }++ masterSf = (fromJust . getMasterSubflow) mptcpCon+++{-+ Generate requests+it iterates over local interfaces and try to connect+-}+meshOnMasterEstablishement :: MptcpSocket -> MptcpConnection -> ExistingInterfaces -> [MptcpPacket]+meshOnMasterEstablishement mptcpSock con paths = do+ foldr (meshGenPkt mptcpSock con) [] paths+++
+ src/Net/Mptcp/Types.hs view
@@ -0,0 +1,46 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE DeriveGeneric, CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedStrings #-}+module Net.Mptcp.Types+where++import Data.Word+import Data.Aeson+import Net.IP+import Net.Mptcp.Connection+import Control.Lens ((^.))++--type MptcpToken = Word32+--type LocId = Word8+----+---- |Same as SockDiagMetrics+---- data SubflowWithMetrics = SubflowWithMetrics {+---- subflowSubflow :: TcpConnection+---- -- for now let's retain DiagTcpInfo only+---- , metrics :: [SockDiagExtension]+---- }++-- | Remote port+data RemoteId = RemoteId {+ remoteAddress :: IP+ , remotePort :: Word16+}++-- export to the format expected by mptcpnumerics+-- could be automatically generated ?+-- toJSON :: MptcpConnection -> Value+instance ToJSON MptcpConnection where+ toJSON mptcpConn = object+ [ "name" .= toJSON (show $ mptcpConn ^. mpconClientConfig ^. mecToken)+ , "sender" .= object [+ -- TODO here we could read from sysctl ? or use another SockDiagExtension+ "snd_buffer" .= toJSON (40 :: Int)+ , "capabilities" .= object []+ ]+ , "capabilities" .= object ([])+ -- TODO generated somewhere else+ -- , "subflows" .= object ([])+ ]++
+ src/Net/Mptcp/Upstream/Commands.hs view
@@ -0,0 +1,329 @@+{-+Module: Net.Mptcp.Upstream.Commands+Description : Description+Maintainer : matt+Portability : Linux+-}+{-# LANGUAGE CPP #-}+module Net.Mptcp.Upstream.Commands (+ attrToPair+ , newSubflowPkt+ , makeAttribute+ , resetConnectionPkt+ , subflowFromAttributes+ ) where++-- mptcp-pm+import Net.Mptcp.Upstream.Constants+import Net.Mptcp.Netlink+import Net.Mptcp.Types+import Net.Mptcp.Utils+import Net.Mptcp.Connection+import Net.Stream++-- hackage+-- import Control.Exception (assert)+import Control.Lens ((^.))+import Data.Word (Word16, Word8, Word32)+import Data.Serialize.Get+import Data.Serialize.Put+import Data.ByteString+import qualified Data.Map as Map+import Net.IP+import Net.IPv4+import Net.IPv6+import Net.IPAddress+import System.Linux.Netlink+import System.Linux.Netlink.Constants (fNLM_F_ACK, fNLM_F_REQUEST, fNLM_F_MATCH, fNLM_F_ROOT, eAF_INET)+import Data.Bits ((.|.))+import System.Linux.Netlink.GeNetlink+import Data.Maybe+import Debug.Trace+import Net.Tcp.Connection++genV4SubflowAddress :: MptcpAttr -> IPv4 -> (Int, ByteString)+genV4SubflowAddress attr ip = (fromEnum attr, runPut $ putWord32be w32)+ where+ w32 = getIPv4 ip++genV6SubflowAddress :: MptcpAttr -> IPv6 -> (Int, ByteString)+genV6SubflowAddress _addr = undefined++mptcpListToAttributes :: [MptcpAttribute] -> Attributes+mptcpListToAttributes attrs = Map.fromList $ Prelude.map attrToPair attrs+++{-|+ Generates an Mptcp netlink request+TODO we could fake the Word16/Flag and+-}+genMptcpRequest :: Word16 -- ^the family id+ -> MptcpGenlEvent -- ^The MPTCP command+ -> Bool -- ^Dump answer (returns EOPNOTSUPP if not possible)+ -- -> Attributes+ -> [MptcpAttribute]+ -> MptcpPacket+genMptcpRequest fid cmd dump attrs =+ let+ myHeader = Header (fromIntegral fid) (flags .|. fNLM_F_ACK) 0 0+ geheader = GenlHeader word8Cmd mptcpGenlVer+ flags = if dump then fNLM_F_REQUEST .|. fNLM_F_MATCH .|. fNLM_F_ROOT else fNLM_F_REQUEST+ word8Cmd = fromIntegral (fromEnum cmd) :: Word8++ pkt = Packet myHeader (GenlData geheader NoData) (mptcpListToAttributes attrs)+ -- TODO run an assert on the list filter+ -- hasTokenAttr = Prelude.any (isAttribute (MptcpAttrToken 0)) attrs+ in+ -- assert hasTokenAttr + pkt++hasFamily :: [MptcpAttribute] -> Bool+hasFamily = Prelude.any (isAttribute (SubflowFamily eAF_INET))++--+-- inspired by netlink cATA :: CtrlAttribute -> (Int, ByteString)+attrToPair :: MptcpAttribute -> (Int, ByteString)+attrToPair (MptcpAttrToken token) = (fromEnum MPTCP_ATTR_TOKEN, runPut $ putWord32host token)+attrToPair (RemoteLocatorId loc) = (fromEnum MPTCP_ATTR_REM_ID, runPut $ putWord8 loc)+attrToPair (LocalLocatorId loc) = (fromEnum MPTCP_ATTR_LOC_ID, runPut $ putWord8 loc)+attrToPair (SubflowFamily fam) = let+ fam8 = (fromIntegral $ fromEnum fam) :: Word16+ in (fromEnum MPTCP_ATTR_FAMILY, runPut $ putWord16host fam8)++attrToPair ( SubflowInterface idx) = (fromEnum MPTCP_ATTR_IF_IDX, runPut $ putWord32host idx)+attrToPair ( SubflowSourcePort port) = (fromEnum MPTCP_ATTR_SPORT, runPut $ putWord16host port)+attrToPair ( SubflowDestPort port) = (fromEnum MPTCP_ATTR_DPORT, runPut $ putWord16host port)+attrToPair ( SubflowMaxCwnd limit) =+#ifdef EXPERIMENTAL_CWND + (fromEnum MPTCP_ATTR_CWND, runPut $ putWord32host limit)+#else+ error "not supported"+#endif+attrToPair (SubflowBackup prio) = (fromEnum MPTCP_ATTR_BACKUP, runPut $ putWord8 prio)+-- TODO should depend on the ip putWord32be w32+attrToPair (SubflowSourceAddress addr) =+ case_ (genV4SubflowAddress MPTCP_ATTR_SADDR4) (genV6SubflowAddress MPTCP_ATTR_SADDR6) addr+attrToPair (SubflowDestAddress addr) =+ case_ (genV4SubflowAddress MPTCP_ATTR_DADDR4) (genV6SubflowAddress MPTCP_ATTR_DADDR6) addr++-- TODO prefix with 'e' for enum+-- Map.lookup (fromEnum attr) m+-- getAttribute :: MptcpAttr -> Attributes -> Maybe MptcpAttribute+-- getAttribute attr m+-- | attr == MPTCP_ATTR_TOKEN = Nothing+-- | otherwise = Nothing++-- getAttribute :: (Int, ByteString) -> CtrlAttribute+-- getAttribute (i, x) = fromMaybe (CTRL_ATTR_UNKNOWN i x) $makeAttribute i x++-- getW16 :: ByteString -> Maybe Word16+-- getW16 x = e2M (runGet g16 x)++-- getW32 :: ByteString -> Maybe Word32+-- getW32 x = e2M (runGet g32 x)++-- "either2Maybe"+e2M :: Either a b -> Maybe b+e2M (Right x) = Just x+e2M _ = Nothing++convertAttributesIntoMap :: Attributes -> Map.Map MptcpAttr MptcpAttribute+convertAttributesIntoMap attrs = let+ customFn k val = fromJust (makeAttribute k val)+ newMap = Map.mapWithKey (customFn) attrs+ in+ Map.mapKeys (toEnum) newMap++-- TODO rename fromMap+makeAttributeFromMaybe :: MptcpAttr -> Attributes -> Maybe MptcpAttribute+makeAttributeFromMaybe attrType attrs =+ let res = Map.lookup (fromEnum attrType) attrs in+ case res of+ Nothing -> error $ "Could not build attr " ++ show attrType+ Just bytestring -> makeAttribute (fromEnum attrType) bytestring+++remoteIdFromAttributes :: Attributes -> RemoteId+remoteIdFromAttributes attrs = let+ (SubflowDestPort dport) = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_DPORT attrs+ -- (SubflowFamily _) = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_FAMILY attrs+ SubflowDestAddress destIp = ipFromAttributes False attrs+ -- (SubflowDestPort dport) = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_DPORT attrs+ in+ RemoteId destIp dport+++-- |Retreive IP+-- TODO could check/use addressfamily as well+ipFromAttributes :: Bool -- ^True if source+ -> Attributes -> MptcpAttribute+ipFromAttributes True attrs =+ case makeAttributeFromMaybe MPTCP_ATTR_SADDR4 attrs of+ Just ip -> ip+ Nothing -> case makeAttributeFromMaybe MPTCP_ATTR_SADDR6 attrs of+ Just ip -> ip+ Nothing -> error "could not get the src IP"++ipFromAttributes False attrs =+ case makeAttributeFromMaybe MPTCP_ATTR_DADDR4 attrs of+ Just ip -> ip+ Nothing -> case makeAttributeFromMaybe MPTCP_ATTR_DADDR6 attrs of+ Just ip -> ip+ Nothing -> error "could not get dest IP"+++dumpAttribute :: Int -> ByteString -> String+dumpAttribute attrId value =+ show $ makeAttribute attrId value++-- https://stackoverflow.com/questions/47861648/a-general-way-of-comparing-constructors-of-two-terms-in-haskell?noredirect=1&lq=1+-- attrToPair ( SubflowSourcePort port) = (fromEnum MPTCP_ATTR_SPORT, runPut $ putWord8 loc)+isAttribute :: MptcpAttribute -- ^ to compare with+ -> MptcpAttribute -- ^to compare to+ -> Bool+isAttribute ref toCompare = fst (attrToPair toCompare) == fst (attrToPair ref)++-- create a fake LocalLocatorId+hasLocAddr :: [MptcpAttribute] -> Bool+hasLocAddr attrs = Prelude.any (isAttribute (LocalLocatorId 0)) attrs++-- need to prepare a request+-- type GenlPacket a = Packet (GenlData a)+-- REQUIRES: LOC_ID / TOKEN+-- TODO pass MptcpSubflow+resetConnectionPkt :: MptcpSocket -> [MptcpAttribute] -> MptcpPacket+resetConnectionPkt (MptcpSocket _sock fid) attrs =+ error "reset not implemented yet"+ -- let+ -- _cmd = MPTCP_CMD_REMOVE+ -- in+ -- assert (hasLocAddr attrs) $ genMptcpRequest fid MPTCP_CMD_REMOVE False attrs++-- connectionToken+connectionAttrs :: MptcpConnection -> [MptcpAttribute]+connectionAttrs con = [ MptcpAttrToken $ (con ^. mpconServerConfig ^. mecToken) ]++-- pass token ?+subflowAttrs :: MptcpSubflow -> [MptcpAttribute]+subflowAttrs (MptcpSubflow con _ prio localId remoteId mbIf) = [+ LocalLocatorId $ localId+ , RemoteLocatorId $ remoteId+ , SubflowFamily $ getAddressFamily (conTcpServerIp con)+ , SubflowDestAddress $ conTcpServerIp con+ , SubflowDestPort $ conTcpServerPort con+ -- should fail if doesn't exist+ , SubflowInterface $ fromJust $ mbIf+ -- https://github.com/multipath-tcp/mptcp/issues/338+ , SubflowSourceAddress $ conTcpClientIp con+ , SubflowSourcePort $ conTcpClientPort con+ ]++-- |Generate a request to create a new subflow+capCwndPkt :: MptcpSocket -> MptcpConnection+ -> Word32 -- ^Limit to apply to congestion window+ -> MptcpSubflow -> Either String MptcpPacket+capCwndPkt (MptcpSocket _ fid) mptcpCon limit sf =+#ifdef EXPERIMENTAL_CWND+ assert (hasFamily attrs) (Right pkt)+ where+ oldPkt = genMptcpRequest fid MPTCP_CMD_SND_CLAMP_WINDOW False attrs+ pkt = oldPkt { packetHeader = (packetHeader oldPkt) { messagePID = 42 } }+ attrs = connectionAttrs mptcpCon+ ++ [ SubflowMaxCwnd limit ]+ ++ subflowAttrs sf+#else+ error "support for capping Cwnds not compiled"+#endif++-- sport/backup/intf are optional+newSubflowPkt :: MptcpSocket -> MptcpConnection -> MptcpSubflow -> MptcpPacket+newSubflowPkt (MptcpSocket _ fid) mptcpCon sf = + error "undefined"+ -- assert (hasFamily attrs) pkt+ -- where + -- _cmd = MPTCP_CMD_SUB_CREATE+ -- attrs = connectionAttrs mptcpCon ++ subflowAttrs sf+ -- pkt = genMptcpRequest fid MPTCP_CMD_SUB_CREATE False attrs++-- | Builds an MptcpAttribute from+makeAttribute :: Int -- ^ MPTCP_ATTR_TOKEN value+ -> ByteString+ -> Maybe MptcpAttribute+makeAttribute i val =+ case toEnum i of+ MPTCP_ATTR_TOKEN ->+ case readToken val of+ Left err -> error "could not decode"+ Right mptcpToken -> Just $ MptcpAttrToken mptcpToken++ -- TODO fix+ MPTCP_ATTR_FAMILY ->+ case runGet getWord16host val of+ -- assert it's eAF_INET or eAF_INET6+ Right x -> Just $ SubflowFamily (toEnum ( fromIntegral x :: Int))+ _ -> Nothing+ MPTCP_ATTR_SADDR4 -> SubflowSourceAddress <$> fromIPv4 <$> e2M ( getIPv4FromByteString val)+ MPTCP_ATTR_DADDR4 -> SubflowDestAddress <$> fromIPv4 <$> e2M (getIPv4FromByteString val)+ MPTCP_ATTR_SADDR6 -> SubflowSourceAddress <$> fromIPv6 <$> e2M (getIPv6FromByteString val)+ MPTCP_ATTR_DADDR6 -> SubflowDestAddress <$> fromIPv6 <$> e2M (getIPv6FromByteString val)+ MPTCP_ATTR_SPORT -> SubflowSourcePort <$> port where port = e2M $ runGet getWord16host val+ MPTCP_ATTR_DPORT -> SubflowDestPort <$> port where port = e2M $ runGet getWord16host val+ MPTCP_ATTR_LOC_ID -> Just (LocalLocatorId $ readLocId $ Just val )+ MPTCP_ATTR_REM_ID -> Just (RemoteLocatorId $ readLocId $ Just val )+ MPTCP_ATTR_IF_IDX -> trace ("if_idx: " ++ show val) (+ case runGet getWord32be val of+ Right x -> Just $ SubflowInterface x+ _ -> Nothing)+ -- backup is u8+ MPTCP_ATTR_BACKUP -> Just (SubflowBackup $ readLocId $ Just val )+ MPTCP_ATTR_ERROR -> trace "makeAttribute ERROR" Nothing+ MPTCP_ATTR_TIMEOUT -> undefined+#ifdef EXPERIMENTAL_CWND+ MPTCP_ATTR_CWND -> undefined+#endif+ MPTCP_ATTR_FLAGS -> trace "makeAttribute ATTR_FLAGS" Nothing+ MPTCP_ATTR_UNSPEC -> undefined+ MPTCP_ATTR_RESET_REASON -> undefined+ MPTCP_ATTR_RESET_FLAGS -> undefined++-- mptcpAttributesToMap :: [MptcpAttribute] -> Attributes+-- mptcpAttributesToMap attrs =+-- Map.fromList $map mptcpAttributeToTuple attrs++-- |Converts / should be a maybe ?+-- TODO simplify+subflowFromAttributes :: Attributes -> MptcpSubflow+subflowFromAttributes attrs =+ let+ -- expects a ByteString+ SubflowSourcePort sport = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_SPORT attrs+ SubflowDestPort dport = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_DPORT attrs+ SubflowSourceAddress srcIp' = fromJust $ makeAttributeFromMaybe srcAttr attrs+ -- eAF_INET6 -> fromJust $ makeAttributeFromMaybe MPTCP_ATTR_SADDR6 attrs+ -- ipFromAttributes True attrs+ srcAttr = case family of+ 2 -> MPTCP_ATTR_SADDR4+ 10 -> MPTCP_ATTR_SADDR6+ _ -> error "Unsupported address family"+ SubflowDestAddress dstIp' = fromJust $ makeAttributeFromMaybe dstAttr attrs+ dstAttr = case family of+ 2 -> MPTCP_ATTR_DADDR4+ 10 -> MPTCP_ATTR_DADDR6+ _ -> error "Unsupported address family"+ LocalLocatorId lid = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_LOC_ID attrs+ RemoteLocatorId rid = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_REM_ID attrs+ SubflowInterface intfId = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_IF_IDX attrs+ SubflowFamily family = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_FAMILY attrs++ -- sfFamily = getPort $ fromJust (Map.lookup (fromEnum MPTCP_ATTR_FAMILY) attrs)+ prio = Nothing -- (SubflowPriority N)+ -- using fake streamId+ con = TcpConnection srcIp' dstIp' sport dport (StreamId 0)+ in+ -- TODO fix sfFamily++ -- using fake token+ -- (Just intfId)+ -- TODO set joinToken+ MptcpSubflow con Nothing prio lid rid (Just intfId)+
+ src/Net/Mptcp/Upstream/Constants.chs view
@@ -0,0 +1,61 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-|+Module : Net.Mptcp.Constants+Description : A module to bridge the haskell code to underlying C code++This module is internal and should only be visible by pathmanagers ?+The documentation may be a bit sparse.+Inspired by:+https://stackoverflow.com/questions/6689969/how-does-one-interface-with-a-c-enum-using-haskell-and-ffi++TODO might be best to just use the netlink script and adapt it+https://github.com/Ongy/netlink-hs/issues/7+-}+module Net.Mptcp.Upstream.Constants (+ MptcpAttr(..)+ , MptcpGenlEvent(..)+ , MptcpGenlCommand(..)++ -- Global socket level events+ , MptcpPMAttr(..)++ , mptcpGenlVer+ , mptcpGenlName+ , mptcpGenlCmdGrpName+ , mptcpGenlEvGrpName+)+where++import Data.Word (Word8)+-- import System.Linux.Netlink.Constants (MessageType)+import Data.Bits ()++-- from include/uapi/linux/mptcp.h+#include <linux/mptcp.h>++-- {underscoreToCase}+-- add prefix = "e"+{#enum MPTCP_PM_ATTR_UNSPEC as MptcpPMAttr {} omit (__MPTCP_PM_ATTR_MAX) deriving (Eq, Show, Ord)#}+{#enum MPTCP_ATTR_UNSPEC as MptcpAttr {} omit (__MPTCP_ATTR_AFTER_LAST) deriving (Eq, Show, Ord)#}++-- {underscoreToCase}+-- v1 merged events and commands while v1 distinguishes between the two !+{#enum MPTCP_PM_CMD_UNSPEC as MptcpGenlCommand {} omit ( __MPTCP_PM_CMD_AFTER_LAST) deriving (Eq, Show, Ord)#}++{#enum MPTCP_EVENT_UNSPEC as MptcpGenlEvent {} deriving (Eq, Show, Ord)#}++-- #define MPTCP_PM_NAME "mptcp_pm"+-- #define MPTCP_PM_CMD_GRP_NAME "mptcp_pm_cmds"+-- #define MPTCP_PM_EV_GRP_NAME "mptcp_pm_events"+-- #define MPTCP_PM_VER 0x1++-- |Generic netlink MPTCP version+mptcpGenlVer :: Word8+mptcpGenlVer = {#const MPTCP_PM_VER #}++mptcpGenlName :: String+mptcpGenlName = {#const MPTCP_PM_NAME #}+mptcpGenlCmdGrpName :: String+mptcpGenlCmdGrpName = {#const MPTCP_PM_CMD_GRP_NAME #}+mptcpGenlEvGrpName :: String+mptcpGenlEvGrpName = {#const MPTCP_PM_EV_GRP_NAME #}
+ src/Net/Mptcp/Utils.hs view
@@ -0,0 +1,32 @@+module Net.Mptcp.Utils +where++import Data.Word+import Data.ByteString+import Data.Serialize.Get++-- | TODO change / return Either+readToken :: ByteString -> Either String Word32+readToken val = runGet getWord32host val++getPort :: ByteString -> Word16+getPort val =+ case (runGet getWord16host val) of+ Left _ -> 0+ Right port -> port+++++++-- LocId => Word8+readLocId :: Maybe ByteString -> Word8+readLocId maybeVal = case maybeVal of+ Nothing -> error "Missing locator id"+ Just val -> case runGet getWord8 val of+ -- TODO generate an error here !+ Left _ -> error "Could not get locId !!"+ Right locId -> locId+ -- runGet getWord8 val+
src/Net/SockDiag.hs view
@@ -46,6 +46,9 @@ -- import Net.IPv4 import Net.SockDiag.Constants import Net.Tcp+import Net.Stream+import Net.Tcp.Constants+import Net.Mptcp -- -- import Data.BitSet.Word@@ -89,7 +92,7 @@ -- toBits :: [a] -> Word32 shiftL :: a -> Word32 -instance Enum2Bits TcpState where+instance Enum2Bits TcpStateLinux where shiftL state = B.shiftL 1 (fromEnum state) instance Enum2Bits SockDiagExtensionId where@@ -122,12 +125,12 @@ {-# LANGUAGE FlexibleInstances #-} --- TODO this generates the error "Orphan instance: instance Convertable [TcpState]"--- instance Convertable [TcpState] where+-- TODO this generates the error "Orphan instance: instance Convertable [TcpStateLinux]"+-- instance Convertable [TcpStateLinux] where -- getPut = putStates -- getGet _ = return [] -putStates :: [TcpState] -> Put+putStates :: [TcpStateLinux] -> Put putStates states = putWord32host $ enumsToWord states @@ -145,8 +148,8 @@ , idiag_ext :: [SockDiagExtensionId] -- ^query extended info (word8 size) -- , req_pad :: Word8 -- ^ padding for backwards compatibility with v1 - -- in principle, any kind of state, but for now we only deal with TcpStates- , idiag_states :: [TcpState] -- ^States to dump (based on TcpDump) Word32+ -- in principle, any kind of state, but for now we only deal with TcpStateLinuxs+ , idiag_states :: [TcpStateLinux] -- ^States to dump (based on TcpDump) Word32 , diag_sockid :: InetDiagSockId -- ^inet_diag_sockid } deriving (Eq, Show) @@ -176,7 +179,7 @@ _sockid <- getInetDiagSockid -- TODO reestablish states return $ SockDiagRequest addressFamily protocol- (wordToEnums extended :: [SockDiagExtensionId]) (wordToEnums states :: [TcpState]) _sockid+ (wordToEnums extended :: [SockDiagExtensionId]) (wordToEnums states :: [TcpStateLinux]) _sockid -- |'Put' function for 'GenlHeader' putSockDiagRequestHeader :: SockDiagRequest -> Put@@ -194,18 +197,25 @@ -- |Converts a generic SockDiagMsg into a TCP connection connectionFromDiag :: SockDiagMsg- -> TcpConnection+ -> MptcpSubflow connectionFromDiag msg =- let sockid = idiag_sockid msg in- TcpConnection {- srcIp = fromRight (error "no default for srcIp") (getIPFromByteString (idiag_family msg) (idiag_src sockid))- , dstIp = fromRight (error "no default for destIp") (getIPFromByteString (idiag_family msg) (idiag_dst sockid))- , srcPort = idiag_sport sockid- , dstPort = idiag_dport sockid- , priority = Nothing- , localId = 0- , remoteId = 0- , subflowInterface = Nothing+ let + sockid = idiag_sockid msg+ con = TcpConnection {+ conTcpClientIp = fromRight (error "no default for srcIp") (getIPFromByteString (idiag_family msg) (idiag_src sockid))+ , conTcpServerIp = fromRight (error "no default for destIp") (getIPFromByteString (idiag_family msg) (idiag_dst sockid))+ , conTcpClientPort = idiag_sport sockid+ , conTcpServerPort = idiag_dport sockid+ , conTcpStreamId = StreamId 0+ }+ in+ MptcpSubflow {+ sfConn = con+ , sfJoinToken = Nothing+ , sfPriority = Nothing+ , sfLocalId = 0+ , sfRemoteId = 0+ , sfInterface = Nothing } -- | Serialize SockDiagMsg@@ -462,8 +472,8 @@ {- Generate Check man sock_diag -}-genQueryPacket :: (Either Word64 TcpConnection)- -> [TcpState] -- ^Ignored when querying a single connection+genQueryPacket :: (Either Word64 MptcpSubflow)+ -> [TcpStateLinux] -- ^Ignored when querying a single connection -> [SockDiagExtensionId] -- ^Queried values -> Packet SockDiagRequest genQueryPacket selector tcpStatesFilter requestedInfo = let@@ -480,13 +490,14 @@ in InetDiagSockId 0 0 bstr bstr 0 cookie - Right con -> let- ipSrc = runPut $ putIPAddress (srcIp con)- ipDst = runPut $ putIPAddress (dstIp con)- ifIndex = subflowInterface con+ Right sf -> let+ con = sfConn sf+ ipSrc = runPut $ putIPAddress $ conTcpClientIp con+ ipDst = runPut $ putIPAddress $ conTcpServerIp con+ ifIndex = sfInterface sf _cookie = 0 :: Word64 in- InetDiagSockId (srcPort con) (dstPort con) ipSrc ipDst (fromJust ifIndex) _cookie+ InetDiagSockId (conTcpClientPort con) (conTcpServerPort con) ipSrc ipDst (fromJust ifIndex) _cookie custom = SockDiagRequest eAF_INET eIPPROTO_TCP requestedInfo tcpStatesFilter diag_req in
− src/Net/Tcp.hs
@@ -1,20 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-|-Module : Net.Tcp-Description : Implementation of mptcp netlink path manager-Maintainer : matt-Stability : testing-Portability : Linux---}-module Net.Tcp (- module Net.Tcp.Definitions- , module Net.Tcp.Constants-) where--import Net.Bitset-import Net.Tcp.Constants-import Net.Tcp.Definitions---instance ToBitMask TcpFlag
src/Net/Tcp/Constants.chs view
@@ -1,7 +1,7 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-|-Module : Net.Mptcp.Constants-Description : A module to bridge the haskell code to underlying C code+Module : Net.Tcp.Constants+Description : Bridge the haskell code to underlying C code I consider this module internal. The documentation may be a bit sparse.@@ -22,7 +22,7 @@ #include <tcp_states.h> -- For anonymous C enums, we can use , Bits-{#enum TCP_ESTABLISHED as TcpState {underscoreToCase} deriving (Eq, Show)#}+{#enum TCP_ESTABLISHED as TcpStateLinux {underscoreToCase} deriving (Eq, Show)#} -- tcp_ca_state is a bitfield see -- http://www.yonch.com/tech/linux-tcp-congestion-control-internals
− src/Net/Tcp/Definitions.hs
@@ -1,84 +0,0 @@-{-|-Module : Net.Tcp.Definitions-Description : Implementation of mptcp netlink path manager-Maintainer : matt-Stability : testing-Portability : Linux---}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-module Net.Tcp.Definitions (- TcpConnection (..)- , ConnectionRole (..)- , reverseTcpConnection- , showTcpConnection-)--where--import Data.Aeson-import qualified Data.Text as TS-import Data.Word (Word16, Word32, Word8)-import GHC.Generics-import Net.IP-import Prelude--{- Describe a TCP connection, possibly an Mptcp subflow- The equality implementation ignores several fields--}-data TcpConnection = TcpConnection {- -- TODO use libraries to deal with that ? filter from the command line for instance ?- srcIp :: IP -- ^Source ip- , dstIp :: IP -- ^Destination ip- , srcPort :: Word16 -- ^ Source port- , dstPort :: Word16 -- ^Destination port- , priority :: Maybe Word8 -- ^subflow priority- , localId :: Word8 -- ^ Convert to AddressFamily- , remoteId :: Word8- -- TODO remove could be deduced from srcIp / dstIp ?- , subflowInterface :: Maybe Word32 -- ^Interface of Maybe ? why a maybe ?- -- add TcpMetrics member- -- , tcpMetrics :: Maybe [SockDiagExtension] -- ^Metrics retrieved from kernel--} deriving (Show, Generic, Ord)--tshow :: Show a => a -> TS.Text-tshow = TS.pack . Prelude.show--data ConnectionRole = Server | Client deriving (Show, Eq)---showTcpConnectionText :: TcpConnection -> TS.Text-showTcpConnectionText con =- showIp ( srcIp con) <> ":" <> tshow (srcPort con) <> " -> " <> showIp (dstIp con) <> ":" <> tshow (dstPort con)- where- showIp = Net.IP.encode--showTcpConnection :: TcpConnection -> String-showTcpConnection = TS.unpack . showTcpConnectionText---reverseTcpConnection :: TcpConnection -> TcpConnection-reverseTcpConnection con = con {- srcIp = dstIp con- , dstIp = srcIp con- , srcPort = dstPort con- , dstPort = srcPort con- , priority = Nothing- , localId = remoteId con- , remoteId = localId con- , subflowInterface = Nothing-}--instance FromJSON TcpConnection-instance ToJSON TcpConnection---- TODO create a specific function for it--- ignore the rest-instance Eq TcpConnection where- x == y = srcIp x == srcIp y && dstIp x == dstIp y- && srcPort x == srcPort y && dstPort x == dstPort y- -- /= = not ==--
+ src/Netlink/Route.hs view
@@ -0,0 +1,30 @@+{-|+Module : System.Linux.Netlink.Routing+Description : Implementation of mptcp netlink path manager+Maintainer : matt+Stability : testing+Portability : Linux++-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+module Netlink.Route (+ queryAddrs+)+where+import System.Linux.Netlink.Constants as NLC+-- import System.Linux.Netlink.GeNetlink as GENL++import System.Linux.Netlink as NL+import Data.Bits ((.|.))++-- import System.Linux.Netlink.GeNetlink.Control+import qualified System.Linux.Netlink.Route as NLR+-- import qualified System.Linux.Netlink.Simple as NLS++-- should have this running in parallel+queryAddrs :: NLR.RoutePacket+queryAddrs = NL.Packet+ (NL.Header NLC.eRTM_GETADDR (NLC.fNLM_F_ROOT .|. NLC.fNLM_F_MATCH .|. NLC.fNLM_F_REQUEST) 0 0)+ (NLR.NAddrMsg 0 0 0 0 0)+ mempty
src/app/Main.hs view
@@ -24,7 +24,7 @@ Capture netlink packets in your computer ? -}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE StandaloneDeriving #-}@@ -33,18 +33,27 @@ import Net.IP import Net.Mptcp-import Net.Mptcp.Constants++-- import Net.Mptcp.Fork.Constants as CONST+import qualified Net.Mptcp.Upstream.Constants as C+import qualified Net.Mptcp.Upstream.Commands as CMD+-- import Net.Mptcp.Constants_v1 as CONST import Net.Mptcp.PathManager-import Net.Mptcp.PathManager.Default+import Net.Mptcp.PathManager.Upstream.NdiffPorts import Net.SockDiag import Net.SockDiag.Constants import Net.Tcp+import Net.Mptcp.Utils+import Netlink.Route ++-- hackage+import Control.Lens ((^.)) import Control.Monad (foldM) import Control.Monad.Trans (liftIO) -- import Control.Monad.Trans (liftIO) import Control.Monad.Trans.State (State, StateT, execStateT, get, put)-import Data.Maybe (catMaybes)+import Data.Maybe (catMaybes, fromMaybe) -- import Data.Text (Text) import Foreign.C.Types (CInt) import Options.Applicative hiding (ErrorMsg, empty, value)@@ -61,9 +70,10 @@ -- import System.Linux.Netlink.Helpers -- import System.Log.FastLogger import System.Linux.Netlink.GeNetlink.Control-import qualified System.Linux.Netlink.Route as NLR+-- import qualified System.Linux.Netlink.Route as NLR import qualified System.Linux.Netlink.Simple as NLS +import Text.Pretty.Simple import Data.Word (Word32) import System.Exit import System.Process@@ -75,7 +85,6 @@ import Control.Concurrent import Data.Bits (Bits(..)) import Data.ByteString (ByteString)-import qualified Data.ByteString.Lazy as BL import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as TS@@ -99,11 +108,24 @@ import qualified Polysemy.State as P import Polysemy.Trace (Trace, trace) import qualified Polysemy.Trace as P+import Net.Mptcp.Netlink+import Net.Tcp.Constants+import Net.Stream -- for getEnvDefault, to get TMPDIR value. -- we could pass it as an argument -- import System.Environment.Blank(getEnvDefault) +interfacesToIgnore :: [String]+interfacesToIgnore = [+ "virbr0"+ , "virbr1"+ , "docker0"+ , "nlmon0"+ -- , "ppp0"+ -- , "lo"+ ]+ tshow :: Show a => a -> TS.Text tshow = TS.pack . Prelude.show @@ -118,8 +140,10 @@ -- |the default path manager pathManager :: PathManager-pathManager = meshPathManager+pathManager = ndiffports ++type MptcpToken = Word32 -- |Helper to pass information across functions data MyState = MyState { -- |Socket@@ -141,14 +165,8 @@ -- addJsonKey _ _ xs = xs -dumpCommand :: MptcpGenlEvent -> String-dumpCommand x = show x ++ " = " ++ show (fromEnum x) -dumpMptcpCommands :: MptcpGenlEvent -> String-dumpMptcpCommands MPTCP_CMD_EXIST = dumpCommand MPTCP_CMD_EXIST-dumpMptcpCommands x = dumpCommand x ++ "\n" ++ dumpMptcpCommands (succ x) - -- | Arguments expected on startup data CLIArguments = CLIArguments { @@ -182,7 +200,7 @@ res <- tryReadMVar globalInterfaces case res of Nothing -> putStrLn "No interfaces"- Just interfaces -> Prelude.print interfaces+ Just interfaces -> pPrint interfaces putStrLn "End of dump" @@ -242,24 +260,23 @@ makeMptcpSocket = do -- for legacy reasons this opens a route socket sock <- GENL.makeSocket- res <- getFamilyIdS sock mptcpGenlName+ res <- getFamilyIdS sock C.mptcpGenlName case res of- Nothing -> error $ "Could not find family " ++ mptcpGenlName- Just fid -> return (MptcpSocket sock fid)+ Nothing -> error $ "Could not find family " ++ C.mptcpGenlName+ Just fid -> pure (MptcpSocket sock fid) makeMetricsSocket :: IO NetlinkSocket makeMetricsSocket = makeSocketGeneric eNETLINK_SOCK_DIAG - -- A utility function - threadDelay takes microseconds, which is slightly annoying. sleepMs :: Natural -> IO() sleepMs n = threadDelay $ (fromIntegral n :: Int) * 1000 -- | here we may want to run mptcpnumerics to get some results-updateSubflowMetrics :: NetlinkSocket -> TcpConnection -> IO SockDiagMetrics+updateSubflowMetrics :: NetlinkSocket -> MptcpSubflow -> IO SockDiagMetrics updateSubflowMetrics sockMetrics subflow = do putStrLn "Updating subflow metrics" let queryPkt = genQueryPacket (Right subflow) [TcpListen, TcpEstablished]@@ -318,16 +335,16 @@ mptcpConn <- embed $ readMVar mConn Log.trace "Showing MPTCP connection" Log.trace $ tshow mptcpConn <> "..."- let _token = connectionToken mptcpConn+ -- let _token = connectionToken mptcpConn let tmpdir = out cliArgs -- TODO this is the issue -- not sure it's the master with a set- let _masterSf = Set.elemAt 0 (subflows mptcpConn)+ -- let _masterSf = Set.elemAt 0 (subflows mptcpConn) -- Get updated metrics- lastMetrics <- embed $ mapM (updateSubflowMetrics sockMetrics) (Set.toList $ subflows mptcpConn)- let filename = tmpdir ++ "/" ++ "mptcp_" ++ show (connectionToken mptcpConn) ++ "_" ++ show elapsed ++ ".json"+ lastMetrics <- embed $ mapM (updateSubflowMetrics sockMetrics) (Set.toList $ _mpconSubflows mptcpConn)+ let filename = tmpdir ++ "/" ++ "mptcp_" ++ show (mptcpConn ^. mpconClientConfig ^. mecToken) ++ "_" ++ show elapsed ++ ".json" -- logStatistics filename elapsed mptcpConn lastMetrics duration <- case cliOptimizer cliArgs of@@ -347,10 +364,12 @@ Log.info $ "Requesting to set cwnds..." <> tshow cwnds -- TODO fix -- KISS for now (capCwndPkt mptcpSock )+#ifdef EXPERIMENTAL_CWND let cwndPackets = map (\(cwnd, sf) -> capCwndPkt mptcpSock mptcpConn cwnd sf) (zip cwnds (Set.toList $ subflows mptcpConn))- embed $ mapM_ (sendPacket sock) cwndPackets-+#else + Log.debug $ "Cwnd capping not compiled"+#endif return onSuccessSleepingDelayMs Log.debug $ "Finished monitoring token. Waiting " <> tshow duration embed $ sleepMs duration@@ -372,7 +391,7 @@ -> IO (Maybe [Word32]) getCapsForConnection filename prog mptcpConn metrics = do - let subflowCount = length $ subflows mptcpConn+ let subflowCount = length $ _mpconSubflows mptcpConn -- Data.ByteString.Lazy.writeFile filename jsonBs @@ -391,12 +410,12 @@ return values -- the library contains showAttrs / showNLAttrs-showAttributes :: Attributes -> String-showAttributes attrs =- let- mapped = Map.foldrWithKey (\k v -> (dumpAttribute k v ++) ) "\n " attrs- in- mapped+-- showAttributes :: Attributes -> String+-- showAttributes attrs =+-- let+-- mapped = Map.foldrWithKey (\k v -> (dumpAttribute k v ++) ) "\n " attrs+-- in+-- mapped putW32 :: Word32 -> ByteString putW32 x = runPut (putWord32host x)@@ -404,6 +423,8 @@ -- I want to override the GenlHeader version newtype GenlHeaderMptcp = GenlHeaderMptcp GenlHeader++-- TODO remove shouldn't be a show instance instance Show GenlHeaderMptcp where show (GenlHeaderMptcp (GenlHeader cmd ver)) = "Header: Cmd = " ++ show cmd ++ ", Version: " ++ show ver ++ "\n"@@ -426,57 +447,101 @@ cmd = genlCmd hdr in putStrLn $ show ("Inspecting answer custom:\n" ++ showHeaderCustom hdr- ++ "Supposing it's a mptcp command: " ++ dumpCommand ( toEnum $ fromIntegral cmd))-+ ++ "Supposing it's a mptcp command: ") inspectAnswer pkt = putStrLn $ "Inspecting answer:\n" ++ showPacket pkt --- should have this running in parallel-queryAddrs :: NLR.RoutePacket-queryAddrs = NL.Packet- (NL.Header NLC.eRTM_GETADDR (NLC.fNLM_F_ROOT .|. NLC.fNLM_F_MATCH .|. NLC.fNLM_F_REQUEST) 0 0)- (NLR.NAddrMsg 0 0 0 0 0)- mempty-- -- |Deal with events for already registered connections -- Warn: MPTCP_EVENT_ESTABLISHED registers a "null" interface -- or a list of packets to send +-- |Filter connections+-- This should be configurable in some way+acceptConnection :: TcpConnection -> Maybe [TcpConnection] -> Bool+acceptConnection subflow mFilteredConnections =+ case mFilteredConnections of+ Nothing -> True+ -- or notElem+ Just filtered -> subflow `elem` filtered++-- |+mapSubflowToInterfaceIdx :: IP -> IO (Maybe Word32)+mapSubflowToInterfaceIdx ip = do++ res <- tryReadMVar globalInterfaces+ case res of+ Nothing -> error "Couldn't access the list of interfaces"+ Just interfaces -> return $ mapIPtoInterfaceIdx interfaces ip++++registerMptcpConnection :: MptcpToken -> MptcpSubflow -> StateT MyState IO ()+registerMptcpConnection token subflow = (do+ oldState <- get+ let (MyState mptcpSock conns cliArgs filtered) = oldState+ if acceptConnection (sfConn subflow) filtered == False+ then do+ -- infoM "main" $ "filtered out connection:" ++ show subflow+ return ()+ else (do+ -- putStrLn $ "accepted connection :" ++ show subflow+ -- should we add the subflow yet ? it doesn't have the correct interface idx+ mappedInterface <- liftIO $ mapSubflowToInterfaceIdx (conTcpClientIp $ sfConn subflow)+ let fixedSubflow = subflow { sfInterface = mappedInterface }+ let mptcpCon = MptcpConnection (StreamId 0) (MptcpEndpointConfiguration 0 token 0) (MptcpEndpointConfiguration 0 0 0) Set.empty+ let newMptcpConn = mptcpConnAddSubflow (mptcpCon) fixedSubflow++ newConn <- liftIO $ newMVar newMptcpConn+ -- putStrLn $ "Connection established !!\n"++ -- create a new+ sockMetrics <- liftIO $ makeMetricsSocket+ -- start monitoring connection+ -- let threadId = undefined+ threadId <- liftIO $ forkOS (+ -- -- runLogAction @IO (contramap message logTextStdout) $ interpretDataLogColog @Message $ progData+ runM $ P.traceToStdout $ interpretLogStdout$+ startMonitorConnection cliArgs 0 mptcpSock sockMetrics newConn+ )++ -- putStrLn $ "Inserting new MVar "+ put (oldState {+ connections = Map.insert token (threadId, newConn) (connections oldState)+ })+ ))+ -- TODO maybe the path manager should be part of the MptcpConnection dispatchPacketForKnownConnection :: MptcpSocket -> MptcpConnection- -> MptcpGenlEvent+ -> C.MptcpGenlEvent -> Attributes- -> AvailablePaths+ -> ExistingInterfaces -> (Maybe MptcpConnection, [MptcpPacket])-dispatchPacketForKnownConnection mptcpSock con event attributes availablePaths = let- token = connectionToken con- subflow = subflowFromAttributes attributes+dispatchPacketForKnownConnection mptcpSock con event attributes existingInterfaces = let+ token = con ^. mpconClientConfig ^. mecToken+ subflow = CMD.subflowFromAttributes attributes in case event of -- let the Path manager kick in- MPTCP_EVENT_ESTABLISHED -> let- -- onMasterEstablishement mptcpSock- -- Needs IO because of NetworkInterface- newPkts = (onMasterEstablishement pathManager) mptcpSock con availablePaths- in- (Just con, newPkts)+ C.MPTCP_EVENT_ESTABLISHED -> let+ -- onMasterEstablishement mptcpSock+ -- Needs IO because of NetworkInterface+ newPkts = (onMasterEstablishement pathManager) mptcpSock con existingInterfaces+ in+ (Just con, newPkts) -- TODO trigger the pathManager again, fix the remote interpretation- MPTCP_EVENT_ANNOUNCED -> let+ C.MPTCP_EVENT_ANNOUNCED -> let -- what if it's local- remId = remoteIdFromAttributes attributes- -- newConn = mptcpConnAddRemoteId con remId newConn = con in (Just newConn, []) - MPTCP_EVENT_CLOSED -> (Nothing, [])+ C.MPTCP_EVENT_CLOSED -> (Nothing, []) - MPTCP_EVENT_SUB_ESTABLISHED -> let+ C.MPTCP_EVENT_SUB_ESTABLISHED -> let newCon = mptcpConnAddSubflow con subflow in (Just newCon,[])@@ -488,7 +553,7 @@ -- return newState -- TODO remove- MPTCP_EVENT_SUB_CLOSED -> let+ C.MPTCP_EVENT_SUB_CLOSED -> let newCon = mptcpConnRemoveSubflow con subflow in (Just newCon, [])@@ -496,63 +561,11 @@ -- MPTCP_CMD_EXIST -> con _ -> error $ "should not happen " ++ show event ---- |Filter connections--- This should be configurable in some way-acceptConnection :: TcpConnection -> Maybe [TcpConnection] -> Bool-acceptConnection subflow mFilteredConnections =- case mFilteredConnections of- Nothing -> True- -- or notElem- Just filtered -> subflow `elem` filtered---- |-mapSubflowToInterfaceIdx :: IP -> IO (Maybe Word32)-mapSubflowToInterfaceIdx ip = do-- res <- tryReadMVar globalInterfaces- case res of- Nothing -> error "Couldn't access the list of interfaces"- Just interfaces -> return $ mapIPtoInterfaceIdx interfaces ip----registerMptcpConnection :: MptcpToken -> TcpConnection -> StateT MyState IO ()-registerMptcpConnection token subflow = (do- oldState <- get- let (MyState mptcpSock conns cliArgs filtered) = oldState- if acceptConnection subflow filtered == False- then do- -- infoM "main" $ "filtered out connection:" ++ show subflow- return ()- else (do- -- putStrLn $ "accepted connection :" ++ show subflow- -- should we add the subflow yet ? it doesn't have the correct interface idx- mappedInterface <- liftIO $ mapSubflowToInterfaceIdx (srcIp subflow)- let fixedSubflow = subflow { subflowInterface = mappedInterface }- -- let newMptcpConn = (MptcpConnection token [] Set.empty Set.empty)- let newMptcpConn = mptcpConnAddSubflow (- MptcpConnection token Set.empty Set.empty Set.empty (cliOptimizer cliArgs)- ) fixedSubflow-- newConn <- liftIO $ newMVar newMptcpConn- -- putStrLn $ "Connection established !!\n"-- -- create a new- sockMetrics <- liftIO $ makeMetricsSocket- -- start monitoring connection- -- let threadId = undefined- threadId <- liftIO $ forkOS (- -- -- runLogAction @IO (contramap message logTextStdout) $ interpretDataLogColog @Message $ progData- runM $ P.traceToStdout $ interpretLogStdout$- startMonitorConnection cliArgs 0 mptcpSock sockMetrics newConn- )+-- allowedInterfaces :: ExistingInterfaces+-- allowedInterfaces = - -- putStrLn $ "Inserting new MVar "- put (oldState {- connections = Map.insert token (threadId, newConn) (connections oldState)- })- ))+filterInterfaces :: ExistingInterfaces -> ExistingInterfaces+filterInterfaces existingInterfaces = flip Map.filter existingInterfaces (\x -> interfaceName x `elem` interfacesToIgnore) -- |Treat MPTCP events depending on if the connection is known or not dispatchPacket :: MyState -> MptcpPacket -> IO MyState@@ -563,15 +576,17 @@ -- i suppose token is always available right ? token :: MptcpToken- token = case Map.lookup (fromEnum MPTCP_ATTR_TOKEN) attributes of+ token = case Map.lookup (fromEnum C.MPTCP_ATTR_TOKEN) attributes of Nothing -> error "Could not retreive token " Just bstr -> fromRight (error "could not retreive token") (readToken bstr) maybeMatch = Map.lookup token (connections oldState) in do putStrLn "Fetching available paths"- availablePaths <- readMVar globalInterfaces+ existingInterfaces <- readMVar globalInterfaces+ -- TODO filter the map based on values putStrLn $ "dispatch cmd " ++ show cmd ++ " for token " ++ show token+ let allowedInterfaces = filterInterfaces existingInterfaces case maybeMatch of -- Unknown token@@ -580,23 +595,24 @@ putStrLn $ "Unknown token/connection " ++ show token case cmd of - MPTCP_EVENT_ESTABLISHED -> do- -- putStrLn "Ignoring Creating EVENT"+ C.MPTCP_EVENT_ESTABLISHED -> do+ putStrLn "Ignoring EVENT established" -- let newMptcpConn = (MptcpConnection token [] Set.empty Set.empty) return oldState - MPTCP_EVENT_CREATED -> let- subflow = subflowFromAttributes attributes- in+ C.MPTCP_EVENT_CREATED -> let+ subflow = CMD.subflowFromAttributes attributes+ in do+ putStrLn "New EVENT_CREATED" execStateT (registerMptcpConnection token subflow) oldState- _ -> return oldState+ _ -> putStrLn "Ignoring event" >> return oldState Just (threadId, mvarConn) -> do putStrLn "MATT: Received request for a known connection " mptcpConn <- takeMVar mvarConn putStrLn "Forwarding to dispatchPacketForKnownConnection "- case dispatchPacketForKnownConnection mptcpSock mptcpConn cmd attributes availablePaths of+ case dispatchPacketForKnownConnection mptcpSock mptcpConn cmd attributes allowedInterfaces of (Nothing, _) -> do putStrLn $ "Killing thread " ++ show threadId killThread threadId@@ -608,7 +624,7 @@ -- TODO update state putStrLn "List of requests made on new master:"- mapM_ (\pkt -> sendPacket mptcpSockRaw pkt) pkts+ mapM_ (sendPacket mptcpSockRaw) pkts let newState = oldState { connections = Map.insert token (threadId, mvarConn) (connections oldState) }@@ -659,7 +675,10 @@ if errCode == 0 then putStrLn $ "Received acknowledgement for " ++ show hdr else- putStrLn $ "Error msg of type " ++ showErrCode errCode ++ " Packet content:\n" ++ show errPacket+ putStrLn $ unlines [+ "Error msg of type " ++ showErrCode errCode+ , "Packet content:\n" ++ show errPacket+ ] return s @@ -675,6 +694,7 @@ showErrCode err | Errno err == ePERM = "EPERM" | Errno err == eOK = "EOK"+ | Errno err == eOPNOTSUPP = "Operation not supported" | otherwise = show err -- showErrCode err = case err of@@ -705,18 +725,17 @@ -- TODO use polysemy State / log / trace- listenToEvents :: Members '[ Log, P.Trace, P.State MyState, P.Embed IO ] r- => CtrlAttrMcastGroup+ => Word32 -> Sem r ()-listenToEvents my_group = do+listenToEvents eventGrpId = do myState <- P.get- let (MptcpSocket sock fid) = socket myState+ let (MptcpSocket sock fid) = socket myState - embed $ joinMulticastGroup sock (grpId my_group)- trace $ "Joined grp " ++ grpName my_group+ embed $ joinMulticastGroup sock eventGrpId+ trace $ "Joined grp " ++ show eventGrpId _ <- P.embed $ doDumpLoop myState trace "end of listenToEvents" @@ -781,7 +800,7 @@ instance ToJSON SockDiagExtension where toJSON (tcpInfo@DiagTcpInfo {} ) = let -- rtt = tcpi_rtt tcpInfo- tcpState = toEnum $ fromIntegral ( tcpi_state tcpInfo) :: TcpState+ tcpState = toEnum $ fromIntegral ( tcpi_state tcpInfo) :: TcpStateLinux -- TODO could log ca_state ? in@@ -833,12 +852,13 @@ toJSON (SockDiagMetrics msg metrics) = let sf = connectionFromDiag msg- tcpState = toEnum $ fromIntegral ( idiag_state msg) :: TcpState+ con = sfConn sf+ tcpState = toEnum $ fromIntegral ( idiag_state msg) :: TcpStateLinux initialValue = object [- "srcIp" .= toJSON (srcIp sf)- , "dstIp" .= toJSON (dstIp sf)- , "srcPort" .= toJSON (srcPort sf)- , "dstPort" .= toJSON (dstPort sf)+ "srcIp" .= toJSON (conTcpClientIp con)+ , "dstIp" .= toJSON (conTcpServerIp con)+ , "srcPort" .= toJSON (conTcpClientPort con)+ , "dstPort" .= toJSON (conTcpServerPort con) -- doesnt work as subflow id -- , "subflow_id" .= idiag_uid msg ]@@ -851,11 +871,11 @@ -- |Updates the list of interfaces -- should run in background-trackSystemInterfaces :: IO ()-trackSystemInterfaces = do+trackSystemInterfaces :: [String] -> IO ()+trackSystemInterfaces interfacesToIgnore' = do -- check routing information routingSock <- NLS.makeNLHandle (const $ pure ()) =<< NL.makeSocket- let cb = NLS.NLCallback (pure ()) (handleAddr defaultPathManagerConfig . runGet getGenPacket)+ let cb = NLS.NLCallback (pure ()) (handleAddr interfacesToIgnore' . runGet getGenPacket) NLS.nlPostMessage routingSock queryAddrs cb NLS.nlWaitCurrent routingSock dumpSystemInterfaces@@ -888,31 +908,36 @@ Log.info "Now Tracking system interfaces..." embed $ putMVar globalInterfaces Map.empty- routeNl <- embed $ forkIO trackSystemInterfaces+ routeNl <- embed $ forkIO (trackSystemInterfaces []) Log.debug "socket created. MPTCP Family id " mptcpSocket <- embed makeMptcpSocket let (MptcpSocket sock fid) = mptcpSocket+ mcastMptcpGroups <- embed $ getMulticastGroups sock fid -- TODO Log.debug- embed $ mapM_ Prelude.print mcastMptcpGroups+ embed $ pPrint mcastMptcpGroups+ let mcEventGroupId = fromMaybe (error "Could not find the mptcp event multicast group") (getMulticast C.mptcpGenlEvGrpName mcastMptcpGroups) -- use fmap instead- filteredConns <- case Main.cliFilter options of- Nothing -> return Nothing- Just filename -> do- Log.info ("Loading connections whitelist from " <> tshow filename <> "...")- filteredConnectionsStr <- embed $ BL.readFile filename- case Data.Aeson.eitherDecode filteredConnectionsStr of- Left errMsg -> error ("Failed loading " ++ filename ++ ":\n" ++ errMsg)- Right list -> return list+ -- filteredConns <- case Main.cliFilter options of+ -- Nothing -> return Nothing+ -- Just filename -> do+ -- Log.info ("Loading connections whitelist from " <> tshow filename <> "...")+ -- filteredConnectionsStr <- embed $ BL.readFile filename+ -- case Data.Aeson.eitherDecode filteredConnectionsStr of+ -- Left errMsg -> error ("Failed loading " ++ filename ++ ":\n" ++ errMsg)+ -- Right list -> return list+ -- Log.info ("Loading connections whitelisted connections..." <> (tshow filteredConns)) - Log.info ("Loading connections whitelisted connections..." <> (tshow filteredConns))+ let filteredConns = Nothing + -- TODO update the state let globalState = MyState mptcpSocket Map.empty options filteredConns - mapM_ (\x -> P.evalState globalState (listenToEvents x)) mcastMptcpGroups+ P.evalState globalState (listenToEvents mcEventGroupId)+ -- return () -- putStrLn $ " Groups: " ++ unwords ( map grpName mcastMptcpGroups )
test/Main.hs view
@@ -9,6 +9,10 @@ import Net.Mptcp import Net.SockDiag import Net.Tcp+import Net.Bitset+import Net.Mptcp+import Net.Stream+import Net.Tcp.Constants import System.Exit import Test.HUnit @@ -33,22 +37,27 @@ 513 ( enumsToWord [TcpEstablished, TcpListen] ) --iperfConnection = TcpConnection {- srcIp = fromIPv4 localhost- , dstIp = fromIPv4 localhost- , srcPort = 5000- , dstPort = 1000+iperfConnection = let + con = TcpConnection {+ conTcpClientIp = (fromIPv4 localhost)+ , conTcpServerIp = fromIPv4 localhost+ , conTcpClientPort = 5000+ , conTcpServerPort = 1000+ , conTcpStreamId = (StreamId 0)+ }+ in MptcpSubflow {+ sfConn = con -- placeholder values- , priority = Nothing- , subflowInterface = Nothing- , localId = 0- , remoteId = 0+ , sfJoinToken = Just 0+ , sfPriority = Nothing+ , sfInterface = Nothing+ , sfLocalId = 0+ , sfRemoteId = 0 } -modifiedConnection = iperfConnection { subflowInterface = Just 0 }+modifiedConnection = iperfConnection { sfInterface = Just 0 } -filteredConnections :: [TcpConnection]+filteredConnections :: [MptcpSubflow] filteredConnections = [ iperfConnection ] @@ -58,6 +67,7 @@ +instance ToBitMask TcpFlag -- check we can read an hex from tshark -- 0x00000012@@ -79,10 +89,11 @@ results <- runTestTT $ TestList [ TestLabel "subflow is correctly filtered" connectionFilter , TestCase $ assertBool "connection should be equal" (iperfConnection == iperfConnection)- , TestCase $ assertEqual "connection should be equal despite different interfaces"- iperfConnection modifiedConnection- , TestCase $ assertBool "connection should be considered as in list"- (modifiedConnection `elem` filteredConnections)+ -- , TestCase $ assertEqual "connection should be equal despite different interfaces"+ -- iperfConnection modifiedConnection+ -- TODO restore+ -- , TestCase $ assertBool "connection should be considered as in list"+ -- (modifiedConnection `elem` filteredConnections) -- , TestCase $ assertBool "connection should not be considered as in list" -- (modifiedConnection `notElem` filteredConnections) , TestList [