diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,5 @@ +# Revision history for mptcpanalyzer + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,674 @@ +GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + {one line to give the program's name and a brief idea of what it does.} + Copyright (C) {year} {name of author} + + 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 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + {project} Copyright (C) {year} {fullname} + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,107 @@ + +* [Presentation](#presentation) +* [Installation](#installation) +* [Help](#faq) +* [Related tools](#related_tools) + + + + +Presentation +=== + +Mptcpanalyzer is a tool conceived to help with MPTCP pcap analysis (as [mptcptrace] for instance). + +It accepts packet capture files (\*.pcap) as inputs and from there you can: + +- list MPTCP connections +- compute statistics on a specific MPTCP connection (list of subflows, reinjections, subflow actual contributions...) +- export a CSV file with MPTCP fields +- plot one way delays +- ... + +Commands are self documented with autocompletion. +The interpreter with autocompletion that can generate & display plots such as the following: + +``` +cabal configure --enable-profiling +cabal run mptcpanalyzer "load-pcap examples/client_2_filtered.pcapng" -- +RTS +-xc +``` + +# Installation + +You will need a wireshark version __>= 3.6.0__ . + +Until changes are upstreamed, you will need this fork of optparse-applicative +- https://github.com/teto/optparse-applicative/tree/quantum-wip-16.1 +to get autocompletion working + + +# How to use + +mptcpanalyzer can run into 2 modes: + 1. interactive mode (default): an interpreter with some basic completion will accept your commands. There is also interactive help. + 2. otherwise, it will consider the unknow arguments as one command, the same that could be used interactively + +For example, we can load mptcp pcaps (available at [wireshark wiki](https://wiki.wireshark.org/SampleCaptures#MPTCP) or in this [folder](./examples)). + +``` +mptcpanalyzer "map-tcp examples/client_2_filtered.pcapng examples/server_2_filtered.pcapng 0" +mptcpanalyzer "load-pcap examples/client_2_filtered.pcapng" +``` + +or for a live analysis: +``` +plot-mptcp-live 10.0.0.1 10.0.0.2 33784 5201 client lo -f examples/client_2_cleaned_start.pcapng +``` + +See [this blog](http://teto.github.io/tags/mptcp.html) for more tutorials about mptcpanalyzer. + +NB: in a local repository, you can run the previous command prefixed with +`mptcpanalyzer$ cabal run -- COMMAND`. + +# How to develop/contribute + +See [CONTRIBUTING](./CONTRIBUTING.md). + +## Dependencies + +- [polysemy](polysemy) to handle effects +- [Frames](frames) to analyze data +- [haskell-chart](haskell-chart) with the svg backend +- [wireshark](wireshark-mptcp) to convert packet captures (.pcapng) to csv files. + + +# Roadmap + +- improve caching +- improve autocompletion +- live statistics/plotting +- plugins ? +- ability to leverage the API in ihaskell ? + +# Related tools + +Similar software: + +| Tool | Description | +|------------------------|-------------------------------------------------------------------------------| +| [mptcptrace] | C based: [an example](http://blog.multipath-tcp.org/blog/html/2015/02/02/mptcptrace_demo.html) | +| [mptcpplot] | C based developed at NASA: [generated output example](https://roland.grc.nasa.gov/~jishac/mptcpplot/) | + + +# Acknowledgements + +This project is founded by ![NGI pointer](img/ngi_logo.png). + +[mptcptrace]: https://bitbucket.org/bhesmans/mptcptrace +[mptcpplot]: https://github.com/nasa/multipath-tcp-tools/ +[hk-img]: https://img.shields.io/hackage/v/mptcpanalyzer.svg?logo=haskell +[hk]: https://hackage.haskell.org/package/mptcpanalyzer +[replica]: https://github.com/berewt/REPLica +wireshark-mptcp: https://www.wireshark.org/docs/dfref/m/mptcp.html +polysemy: https://hackage.haskell.org/package/polysemy +diagrams: https://hackage.haskell.org/package/diagrams +frames: https://hackage.haskell.org/package/Frames +shelltestrunner: https://github.com/simonmichael/shelltestrunner diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main where + +import Distribution.Extra.Doctest (defaultMainWithDoctests) + +main :: IO () +main = defaultMainWithDoctests "doctests" diff --git a/mptcpanalyzer.cabal b/mptcpanalyzer.cabal new file mode 100644 --- /dev/null +++ b/mptcpanalyzer.cabal @@ -0,0 +1,359 @@ +cabal-version: 3.0 +name: mptcpanalyzer +version: 0.0.2.0 +license: GPL-3.0-only +license-file: LICENSE +-- we need custom because of cabal-doctest +build-type: Simple +Author: Matthieu Coudron +Maintainer: teto +Category: Network +Synopsis: A Multipath TCP analyzer +Homepage: https://github.com/teto/quantum +Description: + __mptcpanalyzer__ is a multipath TCP (www.multipath-tcp.org) protocol analyzer. + Multipath TCP is an extension of the Transmission Control Protocol that allows applications to send + one single stream of data over multiple TCP connections. + + This software can automatically plot MPTCP characteristics such as Data Sequence Numbers, Data Acknowledgements etc. + It can also map one packet capture to another to give more detailed statistics such + as One-Way delays and reinjection qualifications. + + * list the MPTCP connections in the pcap + * display chosen statistics on a specific MPTCP connection (list of subflows, number of reinjections, etc) + * convert packet capture files (\*.pcap) to \*.csv files + * plot data sequence numbers, dataacks for all subflows + * can map packets between the client and server pcaps to plot one-way delays + -- |prog| looks for files in certain directories. will try to load your configuration from `$XDG_CONFIG_HOME/mptcpanalyzer/config` + -- TODO restore + -- * caching mechanism: mptcpanalyzer compares your pcap creation time and will + -- regenerate the cache if it exists in `$XDG_CACHE_HOME/mptcpanalyzer/` +extra-doc-files: + CHANGELOG + README.md + +extra-source-files: + README.md CHANGELOG + tests/integration/list-tcp.test + -- benchmarks/* +tested-with: + GHC == 8.10.7 + +Source-repository head + type: git + location: https://github.com/teto/quantum + +Flag WithPolysemy { + Description: Add polysemy plugin + Default: True +} + +Flag Dev { + Description: Relax constraints + Default: True +} + +-- Flag ExtraChecks { +-- Description: Run some extra checks +-- Default: True +-- } + +-- aeson to (de)serialize to json +-- text is used to convert from string and in aeson +-- http://hackage.haskell.org/package/bitset-1.4.8/docs/Data-BitSet-Word.html +common shared-properties + build-depends: + base >= 4.12 + , ansi-terminal + , aeson + , aeson-pretty + , aeson-extra + , Cabal + , Chart >= 1.5 + , Chart-cairo + , Frames + , bytestring + -- , byteunits + -- , time-units + , cereal + , containers + , mptcp + , directory + , filepath + , foldl + , formatting + , hashable + , haskeline >= 0.8.0.0 + , ip + , lens + , mptcp-pm >= 0.0.4 + , mtl + -- to talk with sharkd + , network + , optparse-applicative + , pipes + , pipes-parse + , pipes-safe + , polysemy + , polysemy-log >= 0.2.2.4 + , polysemy-log-co + , process + , readable + , template-haskell + , temporary + , text + , time + , unix + , utf8-string + , vector + , vinyl + , wide-word + -- Debug Adapter Plugins (DAP) + , haskell-dap + , ghci-dap + , haskell-debug-adapter + -- , Chart-diagrams >= 1.5 + -- for plotting that's what is used in Frames + -- polysemybased logger + default-language: Haskell2010 + -- -fno-warn-unused-imports + -- -fforce-recomp makes it build twice + if flag(WithPolysemy) + ghc-options: -fplugin=Polysemy.Plugin + build-depends: polysemy-plugin + + -- if flag(ExtraChecks) + -- ghc-options: -DMPTCP_EXTRA_CHECKS + + if flag(Dev) + cpp-options: + -DDEBUG_CAPTURE=1 + ghc-options: + -- -ddump-splices + -- -ddump-to-file + -- -ddump-timings + -Wno-unused-imports + -- build-depends: polysemy-plugin + -fno-warn-unused-binds + -fno-warn-unused-matches + + -- -ddump-splices to dump TH code + ghc-options: + -Wall + -Werror=missing-methods + -- -Werror=warn-missing-methods + -Wpartial-fields + -- -dth-dec-file + -fwrite-ide-info + -hiedir=.hie + -haddock + -- -fexternal-interpreter + -- -fplugin=Polysemy.Plugin + default-extensions: + -- , OverloadedStrings + FlexibleContexts + , StrictData + , DataKinds + , FlexibleContexts + , GADTs + , LambdaCase + , OverloadedStrings + , PolyKinds + , RankNTypes + , ScopedTypeVariables + , TemplateHaskell + , TypeApplications + , TypeOperators + , TypeFamilies + + +library + import: shared-properties + -- build-depends: + -- aeson-extra + + -- visibility: public + -- Other-modules: + Exposed-Modules: + Tshark.TH + , Tshark.Fields + , Tshark.Capture + , Tshark.Interfaces + , Tshark.Live + , Tshark.Main + , Tshark.Sharkd + -- , Net.Mptcp.Types + , Net.Tcp.Stats + , Net.Mptcp.Stats + -- , Net.Mptcp.Flags + -- , Net.Mptcp.Connection + -- reexport the rest + , MptcpAnalyzer + , MptcpAnalyzer.Prelude + , MptcpAnalyzer.ArtificialFields + , MptcpAnalyzer.Stream + , MptcpAnalyzer.Stats + , MptcpAnalyzer.Loader + , MptcpAnalyzer.Frame + , MptcpAnalyzer.Types + , MptcpAnalyzer.Plots.Types + , MptcpAnalyzer.Debug + , MptcpAnalyzer.Pcap + , MptcpAnalyzer.Cache + , MptcpAnalyzer.Map + , MptcpAnalyzer.Merge + , MptcpAnalyzer.Units + , MptcpAnalyzer.Plots + , MptcpAnalyzer.Plots.Live + , MptcpAnalyzer.Plots.Stream + -- TODO remove les commandes ? + -- , MptcpAnalyzer.Commands + -- , MptcpAnalyzer.Commands.Load + -- , MptcpAnalyzer.Commands.Export + -- , MptcpAnalyzer.Commands.Utils + -- , MptcpAnalyzer.Commands.List + -- , MptcpAnalyzer.Commands.ListMptcp + -- , MptcpAnalyzer.Commands.Plot + -- TODO rename to Utils.Frames + -- , MptcpAnalyzer.Frames.Utils + , MptcpAnalyzer.Utils.Completion + , MptcpAnalyzer.Utils.Text + -- , Connection + build-depends: + Chart + , Chart-cairo + , transformers + hs-source-dirs: src/ + ghc-options: + -haddock + +-- TODO add data-files +executable mptcpanalyzer + import: shared-properties + build-depends: + mptcpanalyzer + , ansi-terminal + , transformers + , lens + Other-modules: + Tshark.Live + , Tshark.Interfaces + , Tshark.Fields + , Tshark.Main + , Tshark.Sharkd + -- , Net.Mptcp.Types + -- reexport the rest + , MptcpAnalyzer + , MptcpAnalyzer.Frame + , MptcpAnalyzer.Map + , MptcpAnalyzer.Loader + , MptcpAnalyzer.Types + , MptcpAnalyzer.Plots.Types + , MptcpAnalyzer.Debug + , MptcpAnalyzer.Pcap + , MptcpAnalyzer.Cache + , MptcpAnalyzer.Stats + , MptcpAnalyzer.Stream + , MptcpAnalyzer.Merge + , MptcpAnalyzer.ArtificialFields + , MptcpAnalyzer.Commands + , MptcpAnalyzer.Commands.Definitions + , MptcpAnalyzer.Commands.Load + , MptcpAnalyzer.Commands.Reinjections + , MptcpAnalyzer.Commands.Export + , MptcpAnalyzer.Commands.Plot + , MptcpAnalyzer.Commands.PlotOWD + , MptcpAnalyzer.Commands.Map + , MptcpAnalyzer.Commands.List + , MptcpAnalyzer.Commands.ListMptcp + , MptcpAnalyzer.Commands.Plot + , MptcpAnalyzer.Plots.Stream + , MptcpAnalyzer.Plots.Live + , MptcpAnalyzer.Prelude + , MptcpAnalyzer.Units + , MptcpAnalyzer.Utils.Completion + , MptcpAnalyzer.Utils.Text + , Net.Mptcp.Stats + , Net.Tcp.Stats + , Tshark.Capture + , Tshark.TH + -- for now reference mptcp-pm but later move part to a core + -- build-depends: mptcp-pm >= 0.0.3 + main-is: app/Main.hs + hs-source-dirs: src/ + -- ghc-options: + -- -threaded -rtsopts -haddock + +-- benchmark map-stream +-- type: exitcode-stdio-1.0 +-- main-is: Map.hs +-- hs-source-dirs: benchmarks +-- build-depends: +-- base +-- , Frames +-- -- criterion depends on optparse-applicative so be careful +-- -- to rely on 0.16.1 fork (master has breaking changes) +-- , criterion +-- , mptcpanalyzer:mptcpanalyzer +-- , polysemy +-- , polysemy-log >= 0.2.2.4 +-- , polysemy-log-co + +-- ghc-options: +-- default-language: Haskell2010 + + +Test-Suite test + type: exitcode-stdio-1.0 + main-is: + Spec.hs + hs-source-dirs: tests + default-language: Haskell2010 + default-extensions: + -- , OverloadedStrings + FlexibleContexts + , StrictData + , DataKinds + other-modules: + Tshark.MainSpec + , Net.Tcp.StatsSpec + , MptcpAnalyzer.PcapSpec + , MptcpAnalyzer.LoaderSpec + , MptcpAnalyzer.MapSpec + , Utils + build-depends: + base >=4.12 && <4.20 + , Cabal + , HUnit + , hspec + , QuickCheck + , mptcp + , mptcpanalyzer + , ip + , Frames + , polysemy + , polysemy-log >= 0.2.2.4 + , polysemy-log-co + ghc-options: + -Wall + -threaded + + +-- doctests are a pain +-- test-suite doctests +-- type: exitcode-stdio-1.0 +-- main-is: doctests.hs +-- build-depends: +-- base +-- , base-compat >=0.10.5 && <0.12 +-- , doctest >=0.15 && <0.18 +-- , QuickCheck >=2.12 && <2.15 +-- , template-haskell +-- , mptcpanalyzer +-- -- there are several custom packages +-- -- exe:example +-- -- x-doctest-components: +-- -- lib:mptcpanalyzer +-- ghc-options: -Wall -threaded +-- hs-source-dirs: tests +-- default-language: Haskell2010 diff --git a/src/MptcpAnalyzer.hs b/src/MptcpAnalyzer.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer.hs @@ -0,0 +1,22 @@ +{-| +Module : MptcpAnalyzer +Description : Top level module +Maintainer : matt +License : GPL-3 + + +* Tutorial + +How to use ? +-} +module MptcpAnalyzer ( + -- * Core Types + + module X +) +where +import MptcpAnalyzer.Cache as X +import MptcpAnalyzer.Frame as X +import MptcpAnalyzer.Loader as X +import MptcpAnalyzer.Types as X +import MptcpAnalyzer.Utils.Completion as X diff --git a/src/MptcpAnalyzer/ArtificialFields.hs b/src/MptcpAnalyzer/ArtificialFields.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/ArtificialFields.hs @@ -0,0 +1,62 @@ +{-| +Module : MptcpAnalyzer.ArtificialFields +Description : A set of artifical fields to ease dataframe processing +Maintainer : matt + + +generated in a postprocess step + +-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +module MptcpAnalyzer.ArtificialFields +where +import MptcpAnalyzer.Stream + +import Net.IP +-- import Net.IPv6 (IPv6(..)) +import GHC.TypeLits (KnownSymbol) +-- import Language.Haskell.TH (Name) +import Data.Map (Map, fromList) +import Data.String +import Data.Text (Text) +import Data.Word (Word16, Word32, Word64, Word8) +import Frames.ShowCSV +import Language.Haskell.TH (Name) +import Options.Applicative +import Tshark.Fields + +-- | Filters a connection depending on its role +data ConnectionRole = RoleServer | RoleClient deriving (Show, Eq, Enum, Read, ShowCSV, Ord) + +showConnectionRole :: (IsString a) => ConnectionRole -> a +showConnectionRole RoleServer = "Server" +showConnectionRole RoleClient = "Client" + +artificialFields :: FieldDescriptions +artificialFields = fromList [ + ("tcpDest", TsharkFieldDesc "" ''ConnectionRole Nothing False) + , ("mptcpDest", TsharkFieldDesc "" ''ConnectionRole Nothing False) + , ("conDest", TsharkFieldDesc "" ''ConnectionRole Nothing False) + , ("packetHash", TsharkFieldDesc "" ''ConnectionRole Nothing False) + ] + +-- TODO remove +-- mergedFields :: [(Text, Name)] +-- mergedFields = [ +-- ("senderIP", ''IP) +-- , ("receiverIP", ''IP) +-- , ("sndTime", ''Double) +-- , ("rcvTime", ''Double) +-- , ("tcpSeq", ''Word32) +-- ] + + +readConnectionRole :: ReadM ConnectionRole +readConnectionRole = eitherReader $ \arg -> case arg of + "server" -> return RoleServer + "client" -> return RoleClient + -- [("client", "")] -> return $ RoleClient + _other -> Left $ "readConnectionRole: cannot parse value `" ++ arg ++ "`. It must be either 'server' or 'client'" diff --git a/src/MptcpAnalyzer/Cache.hs b/src/MptcpAnalyzer/Cache.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Cache.hs @@ -0,0 +1,150 @@ +{-| +Module : MptcpAnalyzer.Cache +Description : Save into/load from a local cache +Maintainer : matt +License : GPL-3 +-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +module MptcpAnalyzer.Cache ( + CacheId(..) + , Cache(..) + , CacheConfig(..) + , runMockCache + , getCache + , putCache + , runCache +) +where + +import MptcpAnalyzer.Pcap +import MptcpAnalyzer.Types + +import Prelude hiding (writeFile) +import System.Directory (doesFileExist) +-- import System.Posix.Files.ByteString +import Control.Exception as CE +import Data.ByteString (writeFile) +import Data.Hashable +import Data.List (intercalate) +import Data.Serialize +import Frames +import Frames.CSV +import GHC.Generics +import Polysemy +import System.FilePath.Posix (takeBaseName) + + +-- | Cache item identifier +data CacheId = CacheId { + cacheDeps :: [FilePath] + , cachePrefix :: String + , cacheSuffix :: String +} deriving (Generic, Show, Eq, Hashable) + +-- | Cache config (this is a test) +-- test +data CacheConfig = CacheConfig { + -- | Folder where to store stuff + cacheFolder :: FilePath + -- | Whether the cachie is fixed + , cacheEnabled :: Bool +} deriving Show + +-- class Serializable a where +-- encode :: a -> String +-- decode :: String -> a + +-- TODO add a cacheConfig ? +-- TODO this should be an effect +data Cache m a where + -- should maybe be a filepath + PutCache :: Serialize res => CacheId -> res -> Cache m Bool + GetCache :: Serialize res => CacheId -> Cache m (Either String res) + IsValid :: CacheId -> Cache m Bool + +makeSem ''Cache + +filenameFromCacheId :: CacheId -> FilePath +filenameFromCacheId cid = + cachePrefix cid ++ intercalate "_" basenames ++ show myHash ++ cacheSuffix cid + where + basenames = map takeBaseName $ cacheDeps cid + -- TODO + -- "hash" + myHash = hash basenames + +-- Return full path to the config folder +getFullPath :: CacheConfig -> CacheId -> FilePath +getFullPath config cid = cacheFolder config ++ "/" ++ filenameFromCacheId cid + + +-- TODO pass cache config +runCache :: Members '[Embed IO] r => CacheConfig -> Sem (Cache : r) a -> Sem r a +runCache config = do + interpret $ \case + PutCache cid frame -> doPutCache config cid frame + GetCache cid -> doGetCache config cid + -- return $ Left "not implemented" + -- use config to get the final path too + -- let csvFilename = filenameFromCacheId cid + -- rpcap <- embed $ loadRows csvFilename + -- return Right rpcap + IsValid cid -> isCacheValid config cid + +-- | Mock cache +-- +runMockCache :: Members '[Embed IO] r => CacheConfig -> Sem (Cache : r) a -> Sem r a +runMockCache config = do + interpret $ \case + PutCache cid frame -> return True + GetCache cid -> return $ Left "Not in cache" + -- return $ Left "not implemented" + -- use config to get the final path too + -- let csvFilename = filenameFromCacheId cid + -- rpcap <- embed $ loadRows csvFilename + -- return Right rpcap + IsValid cid -> return False + +-- first check if the file exists ? +doGetCache :: (Serialize a, Members '[Embed IO] r) + => CacheConfig + -> CacheId + -> Sem r (Either String a) +doGetCache config cid = return $ Left "Not implemented yet" + -- do + -- -- res <- embed $ loadRows csvFilename + -- -- exists <- embed $ fileExist csvFilename + -- res <- embed $ CE.try @IOException $ loadRows csvFilename + -- case res of + -- Left _excpt -> return $ Left "Exception" + -- Right x -> return (Right x) + -- where + -- csvFilename = getFullPath config cid + + +-- TODO reuse export function ? +doPutCache :: (Serialize a, Members '[Embed IO] r) + => CacheConfig -> CacheId -> a -> Sem r Bool +doPutCache config cid resource = + -- writeFile + -- writeCSV :: (ColumnHeaders ts, Foldable f, RecordToList ts, RecMapMethod ShowCSV ElField ts) => FilePath -> f (Record ts) -> IO () + -- produceDSV + -- embed $ writeCSV csvFilename frame >> return True + embed $ do + writeFile csvFilename $ encode resource + return True + where + csvFilename = getFullPath config cid + + +-- TODO log ? / compare inputs date +isCacheValid :: Members '[Embed IO] r => CacheConfig -> CacheId -> Sem r Bool +isCacheValid config cid = + embed $ doesFileExist filename + where + filename = getFullPath config cid diff --git a/src/MptcpAnalyzer/Commands.hs b/src/MptcpAnalyzer/Commands.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Commands.hs @@ -0,0 +1,25 @@ +{- +Module: MptcpAnalyzer.Commands +Description : Description +Maintainer : matt +Portability : Linux +-} +module MptcpAnalyzer.Commands ( + module MptcpAnalyzer.Commands.Load + , module MptcpAnalyzer.Commands.Export +) +where +import Polysemy (Members, Sem, interpret) +import qualified Polysemy.Embed as P +import Polysemy.Log (Log) +import qualified Polysemy.Log as Log +import qualified Polysemy.State as P + +import MptcpAnalyzer.Cache +import MptcpAnalyzer.Commands.Definitions +import MptcpAnalyzer.Commands.Export +import qualified MptcpAnalyzer.Commands.List as CL +import qualified MptcpAnalyzer.Commands.ListMptcp as CL +import MptcpAnalyzer.Commands.Load +import qualified MptcpAnalyzer.Commands.Plot as PL +import MptcpAnalyzer.Types diff --git a/src/MptcpAnalyzer/Commands/Definitions.hs b/src/MptcpAnalyzer/Commands/Definitions.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Commands/Definitions.hs @@ -0,0 +1,84 @@ +module MptcpAnalyzer.Commands.Definitions ( + RetCode(..) + , CommandMapPcap (..) + , CommandArgs (..) + , parserPcapMapping +) +where +import MptcpAnalyzer.Pcap +import MptcpAnalyzer.Plots.Types +import MptcpAnalyzer.Stream +import MptcpAnalyzer.Types + +import Data.Word (Word32) +import MptcpAnalyzer.Utils.Completion (completePath, readFilename) +import Options.Applicative + + +-- | Mapping streams between 2 pcaps is something common in this program. +-- This structure avoids copy/paste. +data CommandMapPcap = CommandMapPcap { + argsMapPcap1 :: FilePath + , argsMapPcap2 :: FilePath + , argsMapStream :: Word32 + , argsMapVerbose :: Bool + , argsMapLimit :: Int -- ^Number of comparisons to show + -- , argsMapMptcp :: Bool -- ^Wether it's an MPTCP +} + +-- | Registered commands +-- TODO make it possible to add some from a plugin +data CommandArgs = + ArgsLoadCsv FilePath Bool + | ArgsHelp + | ArgsQuit + | ArgsLoadPcap FilePath + | ArgsListTcpConnections Bool -- ^ Detailed + | ArgsListMpTcpConnections Bool -- ^ Detailed + | ArgsMapTcpConnections CommandMapPcap Bool + -- ^ Pcap 1 Pcap 2 streamId1 verbose Limit Mptcp + -- | ArgsMapMptcpConnections FilePath FilePath Word32 Bool Int Bool + | ArgsListSubflows Bool + | ArgsListInterfaces + -- ^ _listSubflowsDetailed + | ArgsListReinjections (StreamId Mptcp) + | ArgsTcpSummary Bool (StreamId Tcp) + | ArgsTcpSummaryFromFile FilePath + -- Bool (StreamId Tcp) + | ArgsMptcpSummary Bool (StreamId Mptcp) + | ArgsExport FilePath -- ^ argsExportFilename + -- | plotOut + -- Bool Whether we have to display + -- Bool Whether it's TCP + | ArgsPlotGeneric PlotSettings ArgsPlots + | ArgsQualifyReinjections (PcapMapping Mptcp) Bool + +-- | Return code for user command. Whether to exit program or keep going +data RetCode = Exit | Error String | Continue + +parserPcapMapping :: Bool -> Parser (PcapMapping a) +parserPcapMapping forMptcp = + -- if forMptcp then + PcapMapping <$> + -- else + -- ArgsMapMptcpConnections <$> toto + -- where + -- toto = + strArgument ( + metavar "PCAP1" + <> completer completePath + <> help "File to analyze" + ) + <*> argument readStreamId ( + metavar "TCP_STREAM" + <> help "stream id to analyzer" + ) + <*> strArgument ( + metavar "PCAP2" + <> completer completePath + <> help "File to analyze" + ) + <*> argument readStreamId ( + metavar "TCP_STREAM" + <> help "stream id to analyzer" + ) diff --git a/src/MptcpAnalyzer/Commands/Export.hs b/src/MptcpAnalyzer/Commands/Export.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Commands/Export.hs @@ -0,0 +1,43 @@ +module MptcpAnalyzer.Commands.Export ( + piExportOpts + , cmdExport +) +where + +import MptcpAnalyzer.Cache +import MptcpAnalyzer.Commands.Definitions +import MptcpAnalyzer.Pcap +import MptcpAnalyzer.Types + +import Control.Lens (view, (^.)) +import Frames.CSV (writeCSV) +import Options.Applicative +import Polysemy (Embed, Members, Sem) +import Polysemy.State as P +import Prelude hiding (log) + +piExportOpts :: ParserInfo CommandArgs +piExportOpts = info ( + ArgsExport <$> parserList <**> helper) + ( progDesc "Filename to export to" + ) + where + -- _exportFilename + parserList = argument str (metavar "PCAP" <> completeWith ["toto", "tata"] + <> help "Load a Csv file" + ) + +{-| Export loaded file +-} +cmdExport :: Members '[P.State MyState, Cache, Embed IO] r + => FilePath + -> Sem r RetCode +cmdExport args = do + -- state <- P.get + return Continue + -- let loadedPcap = view loadedFile state + -- fmap writeToCSV loadedPcap >>= \case + -- Just True -> return Continue + -- _ -> return $ Error "test" + -- where + -- writeToCSV frame = writeCSV (_exportFilename args) frame >> return True diff --git a/src/MptcpAnalyzer/Commands/List.hs b/src/MptcpAnalyzer/Commands/List.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Commands/List.hs @@ -0,0 +1,294 @@ +{-| + +Module : MptcpAnalyzer.Commands.List +Description : List (MP)TCP connections in a pcap +Maintainer : matt + +-} +{-# LANGUAGE PackageImports #-} + +module MptcpAnalyzer.Commands.List ( + piListTcpOpts + , piTcpSummaryOpts + , piMptcpSummaryOpts + , cmdListTcpConnections + , cmdTcpSummary + , cmdTcpSummarySharkd + , cmdMptcpSummary +) +where + +import MptcpAnalyzer.ArtificialFields +import MptcpAnalyzer.Cache +import MptcpAnalyzer.Commands.Definitions as CMD +import MptcpAnalyzer.Pcap +import MptcpAnalyzer.Stats +import MptcpAnalyzer.Stream +import MptcpAnalyzer.Types +import MptcpAnalyzer.Utils.Text +import Net.Mptcp +import Net.Mptcp.Stats +import Net.Tcp +import Net.Tcp.Stats +import Net.Tcp.Constants (TcpFlag(..)) +import Tshark.Sharkd + +import Control.Lens hiding (argument) +import Data.Either (fromRight) +import Data.List (intercalate) +import qualified Data.Map as Map +import Frames +import qualified Frames as F +import Frames.CSV +import qualified Frames.InCore as F +import Options.Applicative +import Polysemy (Embed, Member, Members, Sem) +import qualified Polysemy as P +import qualified Polysemy.Embed as P +import Polysemy.Log (Log) +import qualified Polysemy.Log as Log +import qualified Polysemy.State as P +import Polysemy.Trace as P +import Prelude hiding (log) + +piListTcpOpts :: ParserInfo CommandArgs +piListTcpOpts = info ( + ArgsListTcpConnections <$> parserList <**> helper) + ( progDesc "List subflows of an MPTCP connection" + ) + where + parserList = switch (long "detailed" <> help "detail connections") + +piTcpSummaryOpts :: ParserInfo CommandArgs +piTcpSummaryOpts = info ( + piTcpSummary <**> helper) + ( progDesc "Detail a specific TCP connection" + <> footer "Example: summary 0" + ) + where + piTcpSummary :: Parser CommandArgs + piTcpSummary = ArgsTcpSummary <$> switch + ( long "full" + <> help "Print details for each subflow" ) + <*> argument readStreamId ( + metavar "STREAM_ID" + <> help "Stream Id (tcp.stream)" + -- TODO pass a default + ) + + + +piMptcpSummaryOpts :: ParserInfo CommandArgs +piMptcpSummaryOpts = info ( + piMptcpSummary <**> helper) + ( progDesc "Detail a specific TCP connection" + <> footer "mptcp-summary 0" + ) + where + piMptcpSummary :: Parser CommandArgs + piMptcpSummary = ArgsMptcpSummary <$> switch + ( long "full" + <> help "Print details for each subflow" ) + <*> argument readStreamId ( + metavar "STREAM_ID" + <> help "Stream Id (mptcp.stream)" + -- TODO pass a default + ) + +{-| Show a list of all connections + +@ +8 tcp connection(s) + tcp.stream 0: 10.0.0.1:33782 -> 10.0.0.2:05201 + tcp.stream 1: 10.0.0.1:33784 -> 10.0.0.2:05201 + tcp.stream 2: 10.0.0.1:54595 -> 11.0.0.2:05201 + tcp.stream 3: 10.0.0.1:57491 -> 11.0.0.2:05201 + tcp.stream 4: 11.0.0.1:59555 -> 11.0.0.2:05201 + tcp.stream 5: 11.0.0.1:50077 -> 11.0.0.2:05201 + tcp.stream 6: 11.0.0.1:35589 -> 10.0.0.2:05201 + tcp.stream 7: 11.0.0.1:50007 -> 10.0.0.2:05201 +@ +-} +cmdListTcpConnections :: + (Members '[Log, P.Trace, P.State MyState, Cache, Embed IO] r) + => Bool -- ^ detailed + -> Sem r RetCode +cmdListTcpConnections listDetailed = do + -- TODO this part should be extracted so that + state <- P.get + let loadedPcap = view loadedFile state + case loadedPcap of + Nothing -> do + trace "please load a pcap first" + return CMD.Continue + Just frame -> do + let tcpStreams = getTcpStreams frame + let streamIdList = if listDetailed then [] else tcpStreams + -- log $ "Number of rows " ++ show (frameLength frame) + P.trace $ "Number of TCP connections " ++ show (length tcpStreams) + -- TODO use a trace there + mapM_ (P.trace . describeConnection) streamIdList + return CMD.Continue + where + describeConnection streamId = + case buildTcpConnectionFromStreamId frame streamId of + Left msg -> msg + Right aframe -> showConnection (ffCon aframe) + + +{-| Display statistics for the connection: +throughput/goodput + +detailed +-} +cmdTcpSummary :: ( Members '[Log, P.Trace, P.State MyState, Cache, Embed IO] r) + => StreamId Tcp + -> Bool + -> Sem r RetCode +cmdTcpSummary streamId detailed = do + state <- P.get + let loadedPcap = view loadedFile state + case loadedPcap of + Nothing -> return $ CMD.Error "please load a pcap first" + Just frame -> case buildTcpConnectionFromStreamId frame streamId of + Left msg -> return $ CMD.Error msg + Right aframe -> do + -- let _tcpstreams = getTcpStreams frame + P.trace $ showConnection (ffCon aframe) + Log.info $ "Number of rows " <> tshow (frameLength $ ffFrame aframe) + if detailed + then do + res <- showStats aframe RoleServer + P.trace res + res2 <- showStats aframe RoleClient + P.trace res2 + else + pure () + return CMD.Continue + +{-| Display statistics for the connection: +throughput/goodput + +detailed +-} +cmdTcpSummarySharkd :: ( Members '[Log, P.Trace, P.State MyState, Cache, Embed IO] r) + => FilePath + -> StreamId Tcp + -> Bool + -> Sem r RetCode +cmdTcpSummarySharkd pcapPath streamId detailed = do + P.embed $ loadFile pcapPath defaultSocketPath >> return CMD.Continue + -- TODO then ask for the stats about that TCP flow + -- + -- state <- P.get + -- let loadedPcap = view loadedFile state + -- case loadedPcap of + -- Nothing -> return $ CMD.Error "please load a pcap first" + -- Just frame -> case buildTcpConnectionFromStreamId frame streamId of + -- Left msg -> return $ CMD.Error msg + -- Right aframe -> do + -- -- let _tcpstreams = getTcpStreams frame + -- P.trace $ showConnection (ffCon aframe) + -- Log.info $ "Number of rows " <> tshow (frameLength $ ffFrame aframe) + -- if detailed + -- then do + -- res <- showStats aframe RoleServer + -- P.trace res + -- res2 <- showStats aframe RoleClient + -- P.trace res2 + -- else + -- pure () + -- return CMD.Continue + + +-- | Show stats in both directions +showStats :: ( Members '[Log, P.Trace, P.State MyState, Cache, Embed IO] r) + => FrameFiltered TcpConnection Packet + -> ConnectionRole + -> Sem r String +showStats aframe dest = let + aframeWithDest = addTcpDestinationsToAFrame aframe + tcpStats = getTcpStatsFromAFrame aframeWithDest dest + + destFrame = F.filterFrame (\x -> x ^. tcpDest == dest) (ffFrame aframeWithDest) + + in do + P.embed $ writeDSV defaultParserOptions ("debug-" ++ show dest ++ ".csv") destFrame + return $ showTcpStats tcpStats ++ " (" ++ show (frameLength destFrame) ++ " packets)" + + +-- | summarize a few key characteristics like goodput/throughput +showTcpStats :: TcpUnidirectionalStats -> String +showTcpStats s = + "- transferred " ++ show (tusSndNext s - tusMinSeq s + 1 + tusReinjectedBytes s) ++ " bytes " + ++ " over " ++ show (tusEndTime s - tusStartTime s) ++ "s: " + ++ " Throughput " ++ show (getTcpThroughput s) ++ "b/s" + + +{- +Returns something +mptcp stream 0 transferred 469.0 Bytes over 45.831181 sec(456.0 Bytes per second) towards Server. +tcpstream 0 transferred 460.0 Bytes out of 469.0 Bytes, accounting for 98.08% +tcpstream 2 transferred 9.0 Bytes out of 469.0 Bytes, accounting for 1.92% +tcpstream 4 transferred 0.0 Bytes out of 469.0 Bytes, accounting for 0.00% +tcpstream 6 transferred 0.0 Bytes out of 469.0 Bytes, accounting for 0.00% +-} +showMptcpStats :: MptcpUnidirectionalStats -> String +showMptcpStats s = unlines [ + " Mptcp stats towards " ++ show (musDirection s) ++ " :" + , "- Duration " ++ show (getMptcpStatsDuration s) + , "- Goodput " ++ show (getMptcpGoodput s) + , "\n" + , "Applicative Bytes : " ++ show (musApplicativeBytes s) + , "Subflow stats:" + , intercalate "\n" (map showSubflowStats (Map.toList $ musSubflowStats s)) + ] + where + -- ++ show (tusStreamId) + showSubflowStats (sf, sfStats) = let + tcpStats = tssStats sfStats + seqRange = getTcpSeqRange tcpStats + totalApplicationBytes = musApplicativeBytes s + in "stream " ++ show (conTcpStreamId (sfConn sf)) + ++ ": transferred " ++ show seqRange ++ " out of " ++ show totalApplicationBytes + ++ " between " + ++ show (tusStartTime tcpStats) ++ " end time: " ++ show (tusEndTime $ tssStats sfStats) + ++ " , accouting for " ++ show (seqRange / fromIntegral totalApplicationBytes) ++ " %" + +{- +Returns: +mptcp stream 0 transferred 308.0 Bytes over 45.658558 sec(308.0 Bytes per second) towards Client. +tcpstream 0 transferred 308.0 Bytes out of 308.0 Bytes, accounting for 100.00% +tcpstream 2 transferred 0.0 Bytes out of 308.0 Bytes, accounting for 0.00% +tcpstream 6 transferred 0.0 Bytes out of 308.0 Bytes, accounting for 0.00% +mptcp stream 0 transferred 469.0 Bytes over 45.831181 sec(456.0 Bytes per second) towards Server. +tcpstream 0 transferred 460.0 Bytes out of 469.0 Bytes, accounting for 98.08% +tcpstream 2 transferred 9.0 Bytes out of 469.0 Bytes, accounting for 1.92% +tcpstream 4 transferred 0.0 Bytes out of 469.0 Bytes, accounting for 0.00% +tcpstream 6 transferred 0.0 Bytes out of 469.0 Bytes, accounting for 0.00% +-} +cmdMptcpSummary :: (Members '[Log, P.Trace, P.State MyState, Cache, Embed IO] r) + => StreamId Mptcp + -> Bool + -> Sem r RetCode +cmdMptcpSummary streamId detailed = do + state <- P.get + case view loadedFile state of + Nothing -> trace ("please load a pcap first" :: String) >> return CMD.Continue + Just frame -> case buildMptcpConnectionFromStreamId frame streamId of + Left msg -> return $ CMD.Error msg + Right aframe -> do + + let mptcpStatsClient = getMptcpStats aframe RoleClient + let mptcpStatsServer = getMptcpStats aframe RoleServer + + P.trace $ showConnection (ffCon aframe) + Log.debug $ "Number of rows " <> tshow (frameLength frame) + if detailed + then + -- RoleServer + P.trace $ showMptcpStats mptcpStatsClient + -- trace $ showMptcpStats mptcpStatsServer + else + pure () + return CMD.Continue diff --git a/src/MptcpAnalyzer/Commands/ListMptcp.hs b/src/MptcpAnalyzer/Commands/ListMptcp.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Commands/ListMptcp.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} +module MptcpAnalyzer.Commands.ListMptcp ( + piListMpTcpOpts + , cmdListMptcpConnections + , cmdListSubflows +) +where + +import MptcpAnalyzer.Cache +import MptcpAnalyzer.Commands.Definitions as CMD +import MptcpAnalyzer.Commands.List as CMD +import MptcpAnalyzer.Pcap +import MptcpAnalyzer.Stream +import MptcpAnalyzer.Types +import Net.Mptcp + +-- import Net.Mptcp.Types (MptcpConnection(..), MptcpSubflow, showMptcpConnection) + +import qualified Control.Foldl as L +import Control.Lens hiding (argument) +import Data.Either (fromRight) +import Data.Maybe (catMaybes, fromJust) +import qualified Data.Set as Set +import Data.Word (Word16, Word32, Word64, Word8) +import Frames +import "mptcp-pm" Net.Tcp.Constants (TcpFlag(..)) +import Options.Applicative +import qualified Pipes.Prelude as PP +import Polysemy (Embed, Member, Members, Sem) +import qualified Polysemy as P +import Polysemy.State as P +import Polysemy.Trace as P + +import Polysemy.Log (Log) +import qualified Polysemy.Log as Log + +piListMpTcpOpts :: ParserInfo CommandArgs +piListMpTcpOpts = info ( + parserList <**> helper) + ( progDesc "List MPTCP connections" + ) + where + parserList = ArgsListMpTcpConnections <$> switch ( long "detailed" <> help "detail connections") + +piListMptcpSubflowOpts :: ParserInfo CommandArgs +piListMptcpSubflowOpts = info ( + parserList <**> helper) + ( progDesc "List MPTCP connections" + ) + where + parserList = ArgsListSubflows <$> switch ( long "detailed" <> help "detail connections") + + +-- piListMptcpReinjectionsOpts :: ParserInfo CommandArgs +-- piListMptcpReinjectionsOpts = info ( +-- parserList <**> helper) +-- ( progDesc "List MPTCP reinjections" +-- ) +-- where +-- parserList = ArgsListSubflows <$> switch ( long "detailed" <> help "detail connections") + +type SomeFrame = Frame Packet + +-- TODO return mpconStreamId instead +getMpTcpStreams :: SomeFrame -> [StreamIdMptcp] +getMpTcpStreams ps = + catMaybes $ + L.fold L.nub (view mptcpStream <$> ps) + +filterMptcpConnection :: SomeFrame -> StreamId Mptcp -> SomeFrame +filterMptcpConnection frame streamId = + streamPackets + where + streamPackets = filterFrame (\x -> x ^. mptcpStream == Just streamId) frame + + + + +-- buildMptcpConnectionFromRow :: Packet -> TcpConnection +-- buildMptcpConnectionFromRow r = + -- MptcpConnection { + -- srcIp = r ^. ipSource + -- , dstIp = r ^. ipDest + -- , srcPort = r ^. tcpSrcPort + -- , dstPort = r ^. tcpDestPort + -- , priority = Nothing -- for now + -- , localId = 0 + -- , remoteId = 0 + -- , subflowInterface = Nothing + -- } + + + +cmdListSubflows :: (Members '[Log, P.State MyState, P.Trace, Cache, Embed IO] r) + => Bool -- ^ Detailed + -> Sem r RetCode +cmdListSubflows detailed = do + P.trace "not implemented yet" + return CMD.Continue + +{- +-} +cmdListMptcpConnections :: + (Members [Log, P.Trace, P.State MyState, Cache, P.Embed IO] r) + => Bool -- ^ Detailed + -> Sem r RetCode +cmdListMptcpConnections _detailed = do + -- TODO this part should be extracted so that + state <- P.get + let loadedPcap = view loadedFile state + case loadedPcap of + Nothing -> do + P.trace "please load a pcap first" + return CMD.Continue + Just frame -> do + -- log $ "Number of rows " ++ show (frameLength frame) + P.trace $ "Number of MPTCP connections " ++ show (length mptcpStreams) + P.trace $ show mptcpStreams + P.trace $ concatMap showEitherCon mptcpConnections + -- >> + return CMD.Continue + where + mptcpConnections :: [Either String MptcpConnection] + mptcpConnections = map (fmap ffCon . buildMptcpConnectionFromStreamId frame ) mptcpStreams + + showEitherCon :: Either String MptcpConnection -> String + showEitherCon (Left msg) = msg ++ "\n" + showEitherCon (Right mptcpCon) = showConnection mptcpCon ++ "\n" + + mptcpStreams = getMpTcpStreams frame + diff --git a/src/MptcpAnalyzer/Commands/Load.hs b/src/MptcpAnalyzer/Commands/Load.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Commands/Load.hs @@ -0,0 +1,106 @@ +{-| +Module: MptcpAnalyzer.Commands.Load +Maintainer : matt +License : GPL-3 +-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +module MptcpAnalyzer.Commands.Load ( + cmdLoadCsv + , piLoadCsv + , piLoadPcapOpts + , filenameReader +) +where +import MptcpAnalyzer.Cache +import MptcpAnalyzer.Commands.Definitions as CMD +import MptcpAnalyzer.Loader +import MptcpAnalyzer.Pcap +import MptcpAnalyzer.Types +import MptcpAnalyzer.Utils.Completion (completePath, readFilename) +import MptcpAnalyzer.Utils.Text + +-- import Control.Lens hiding (argument) + +import Control.Monad.Trans (liftIO) +import Distribution.Simple.Utils (TempFileOptions(..), withTempFileEx) +import Frames +import Options.Applicative +import System.Exit (ExitCode(..)) +-- import Prelude hiding (log) +import Options.Applicative.Builder (allPositional) +import Polysemy (Embed, Members, Sem) +import Polysemy.Log (Log) +import qualified Polysemy.Log as Log +import qualified Polysemy.State as P +import qualified Polysemy.Trace as P + +import Control.Monad.Trans.Except + (ExceptT(..), runExcept, runExceptT, throwE, withExcept) + +filenameReader :: ReadM FilePath +filenameReader = eitherReader readFilename +-- case readFilename filename of +-- Left err -> ReadM . lift . throwE +-- Right path -> path + +-- (eitherReader readFilename) +loadPcapArgs :: Parser CommandArgs +loadPcapArgs = ArgsLoadPcap <$> + argument filenameReader (metavar "PCAP" + <> completer completePath + <> help "Load a Pcap file" + ) + +cmdLoadCsvArgs :: Parser CommandArgs +cmdLoadCsvArgs = ArgsLoadCsv <$> ( + argument str ( + metavar "CSV" + -- <> action "file" + <> completer completePath + <> help "Load a Csv file" + )) + <*> argument auto (metavar "bool" + <> completeWith ["true", "false"] + <> help "boolean just to test something" + ) + +piLoadCsv :: ParserInfo CommandArgs +piLoadCsv = info (cmdLoadCsvArgs <**> helper) + ( fullDesc + <> progDesc "Load a csv file generated from wireshark" + ) + +piLoadPcapOpts :: ParserInfo CommandArgs +-- <**> helper) +piLoadPcapOpts = info loadPcapArgs + ( fullDesc + <> progDesc "Load a pcap file via wireshark" + <> footer "Example: load-pcap examples/client_2_filtered.pcapng" + <> allPositional + ) + + +-- myHandleParseResult :: ParserResult a -> m CMD.RetCode +-- myHandleParseResult (Success a) = + + + +-- |Load a .csv file +cmdLoadCsv :: (Members '[Log, P.Trace, P.State MyState, Cache, Embed IO] m) + => FilePath -- ^ csv file to load + -> Sem m CMD.RetCode +cmdLoadCsv csvFilename = do + + P.trace $ "Loading " ++ csvFilename + frame <- liftIO $ loadRows csvFilename + -- TODO restore + -- loadedFile .= Just frame + P.modify (\s -> s { _loadedFile = Just frame }) + Log.info $ "Number of rows " <> tshow (frameLength frame) + Log.debug "Frame loaded" >> return CMD.Continue + diff --git a/src/MptcpAnalyzer/Commands/Map.hs b/src/MptcpAnalyzer/Commands/Map.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Commands/Map.hs @@ -0,0 +1,155 @@ +{- +Module: MptcpAnalyzer.Commands.Map +Description : Map tcp.stream ids from one pcap to another +Maintainer : matt +Portability : Linux + + +* Mapping tcp.stream ids from one pcap to another + +-} +module MptcpAnalyzer.Commands.Map ( + mapTcpOpts + , mapMptcpOpts + -- , parserMapConnection + , cmdMapTcpConnection + , cmdMapMptcpConnection +) +where + +import MptcpAnalyzer.Cache +import MptcpAnalyzer.Commands.Definitions as CMD +import MptcpAnalyzer.Commands.List as CMD +import MptcpAnalyzer.Loader +import MptcpAnalyzer.Map +import MptcpAnalyzer.Merge +import MptcpAnalyzer.Pcap +import MptcpAnalyzer.Stream +import MptcpAnalyzer.Types +import MptcpAnalyzer.Utils.Completion (completePath, readFilename) +import MptcpAnalyzer.Utils.Text +import Net.Mptcp + +import Options.Applicative +import Polysemy (Embed, Member, Members, Sem) +import qualified Polysemy as P +import Polysemy.State as P +import Polysemy.Trace as P +import Prelude hiding (log) +-- import Colog.Polysemy (Log, log) +import Data.Either (lefts, rights) +import Data.Function (on) +import Data.List (sortBy, sortOn) +import Data.Text (intercalate) +import qualified Data.Text as TS +import Polysemy.Log (Log) +import qualified Polysemy.Log as Log +import System.Console.ANSI +import System.Console.Haskeline +import Tshark.Main (defaultTsharkPrefs) + + +mapTcpOpts :: ParserInfo CommandArgs +mapTcpOpts = info ( + (parserMapConnection False) <**> helper) + ( progDesc "Attempts to map a TCP connection to another one" + ) + +mapMptcpOpts :: ParserInfo CommandArgs +mapMptcpOpts = info ( + parserMapConnection True <**> helper) + ( progDesc "Maps a MPTCP connection to another one" + ) + +parserMapConnection :: Bool -> Parser CommandArgs +parserMapConnection forMptcp = + ArgsMapTcpConnections <$> ( + CommandMapPcap <$> + strArgument ( + metavar "PCAP1" + <> completer completePath + <> help "File to analyze" + ) + <*> strArgument ( + metavar "PCAP2" + <> completer completePath + <> help "File to analyze" + ) + -- readStreamId + <*> argument auto ( + metavar "TCP_STREAM" + <> help "stream id to analyzer" + ) + <*> switch ( + long "verbose" + <> help "Verbose or not" + ) + <*> option auto ( + metavar "LIMIT" + <> Options.Applicative.value 10 + + <> help "Limit the number of comparisons to display" + ) + ) + <*> option auto ( + metavar "MPTCP" + -- internal is stronger than --belive, hides from all descriptions + <> internal + <> Options.Applicative.value forMptcp + <> help "" + ) + +printInRed :: String -> String +printInRed val = setSGRCode [SetColor Foreground Vivid Red] ++ val ++ setSGRCode [Reset] + +-- TODO this could be made polymorphic using StreamConnection +cmdMapTcpConnection, cmdMapMptcpConnection :: (Members '[Log, P.State MyState, P.Trace, Cache, Embed IO] r ) + => CommandMapPcap -> Sem r RetCode +cmdMapTcpConnection (CommandMapPcap pcap1 pcap2 streamId verbose limit) = do + Log.info "Mapping tcp connections" + res <- buildAFrameFromStreamIdTcp defaultTsharkPrefs pcap1 (StreamId streamId) + res2 <- loadPcapIntoFrame defaultTsharkPrefs pcap2 + case (res, res2) of + (Right aframe, Right frame) -> do + let streamsToCompare = (getTcpStreams frame) + let consToCompare = map (buildTcpConnectionFromStreamId frame) (getTcpStreams frame) + Log.info $ "Best match for " <> tshow (ffCon aframe) <> " is " + Log.info $ "Comparing with stream " <> tshow streamsToCompare + -- TODO sort results and print them + let sortedScores = mapTcpConnection aframe frame + -- TODO only display X first take 5 + P.trace $ TS.unpack $ intercalate "\n" $ map displayScore sortedScores + -- display failures + P.trace $ TS.unpack $ intercalate "\n" $ map displayFailure (lefts consToCompare) + return CMD.Continue + where + displayScore (con, score) = "Score for connection " <> showConnectionText con + <> ": " <> TS.pack (printInRed $ show score) + displayFailure err = "Couldn't compute score for tcp.stream " <> tshow err + _ -> return $ CMD.Error "An error happened" + +cmdMapMptcpConnection (CommandMapPcap pcap1 pcap2 streamId verbose limit) = do + Log.info "Mapping mptcp connections" + res <- buildAFrameFromStreamIdMptcp defaultTsharkPrefs pcap1 (StreamId streamId) + res2 <- loadPcapIntoFrame defaultTsharkPrefs pcap2 + case (res, res2) of + (Right aframe, Right frame) -> do + let streamsToCompare = getMptcpStreams frame + let consToCompare = map (buildTcpConnectionFromStreamId frame) (getTcpStreams frame) + Log.info $ "Best match for " <> tshow (ffCon aframe) <> " is " + Log.debug ("Comparing with stream " <> tshow streamsToCompare) + -- let scores = map (evalScore (ffCon aframe)) (rights consToCompare) + -- let sortedScores = (sortOn snd scores) + let sortedScores = mapMptcpConnection aframe frame + P.trace $ TS.unpack $ intercalate "\n" $ map displayScore sortedScores + P.trace $ TS.unpack $ intercalate "\n" $ map displayFailure (lefts consToCompare) + return CMD.Continue + where + evalScore con1 (FrameTcp con2 _) = (con2, similarityScore con1 con2) + + -- setSGRCode [SetColor Foreground Vivid Red] <> + -- <> setSGRCode [Reset] + displayScore (con, score) = "Score for connection " <> tshow (mpconStreamId con) + <> ": " <> tshow score <> "\n" <> showConnectionText con <> "\n" + displayFailure err = "Couldn't compute score for mptcp.stream " <> tshow err + _ -> return $ CMD.Error "An error happened" diff --git a/src/MptcpAnalyzer/Commands/Plot.hs b/src/MptcpAnalyzer/Commands/Plot.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Commands/Plot.hs @@ -0,0 +1,435 @@ +{-| +Module: MptcpAnalyzer.Commands.Plot +Maintainer : matt +License : GPL-3 + + +-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +module MptcpAnalyzer.Commands.Plot ( + -- * Actual commands that plot + cmdPlotMptcpAttribute + , cmdPlotTcpAttribute + + -- * parsers + , piPlotTcpMainParser + , parserPlotTcpMain + , parserPlotTcpLive + , parserPlotMptcpLive + , parserPlotMptcpMain +) +where + +-- from mptcpanalyzer +import MptcpAnalyzer.ArtificialFields +import MptcpAnalyzer.Cache +import MptcpAnalyzer.Plots.Types +import MptcpAnalyzer.Types +import MptcpAnalyzer.Utils.Completion (completePath, readFilename) +-- import MptcpAnalyzer.Commands.Definitions +import MptcpAnalyzer.Commands.Definitions as CMD +import MptcpAnalyzer.Commands.PlotOWD +import MptcpAnalyzer.Debug +import MptcpAnalyzer.Loader +import MptcpAnalyzer.Pcap +import MptcpAnalyzer.Utils.Text +import Net.IP +import Net.Mptcp +import Net.Tcp +import Tshark.Fields (TsharkFieldDesc(tfieldLabel), baseFields) +-- import Net.IPv4 + +-- hackage +import Frames +import Frames.CSV +import Options.Applicative +import Prelude hiding (filter, log, lookup, repeat) + +-- import Graphics.Rendering.Chart.Backend.Diagrams (defaultEnv, runBackendR) +-- import Graphics.Rendering.Chart.Easy + +import Data.Vinyl (ElField(..), Rec(..), rapply, rmapX, xrec) +import Data.Vinyl.Class.Method +import Data.Word (Word16, Word32, Word64, Word8) +import Graphics.Rendering.Chart.Backend.Cairo (toFile) +import Graphics.Rendering.Chart.Easy hiding (argument) + +import Data.List (filter, intercalate) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Pipes as P +import qualified Pipes.Prelude as P +import Polysemy +import qualified Polysemy as P +import Polysemy.State as P +import Polysemy.Trace as P +-- import Colog.Polysemy (Log, log) +import System.Exit +import System.Process hiding (runCommand) +-- import Data.Time.LocalTime +-- import Data.Foldable (toList) +import qualified Data.Foldable as F +import qualified Data.Map as Map +import Data.Maybe (catMaybes, fromMaybe, isJust, maybeToList) +import qualified Data.Set as Set +import Data.String +import Data.Time +import Data.Vinyl.TypeLevel +import Debug.Trace +import Distribution.Simple.Utils (TempFileOptions(..), withTempFileEx) +import Frames.ShowCSV (showCSV) +import Polysemy.Log (Log) +import qualified Polysemy.Log as Log +import System.Directory (renameFile) +import System.IO (Handle) +import Text.Read (readEither) + +-- import Data.Time.Calendar +import Data.Time.LocalTime +import MptcpAnalyzer.Stream + +mkDate :: Integer -> LocalTime +mkDate jday = + LocalTime (ModifiedJulianDay jday) midnight + +-- Plot MPTCP subflow attributes over time + +-- | Parses options common to all plots like the title +parserPlotSettings :: Bool -> Parser PlotSettings +parserPlotSettings mptcpPlot = PlotSettings + <$> optional (strOption + ( long "out" <> short 'o' + <> help "Save filename of the plot." + <> metavar "OUT" )) + <*> optional ( strOption + ( long "title" <> short 't' + <> help "Overrides the default plot title." + <> metavar "TITLE" )) + <*> switch ( long "display" <> help "Uses xdg-open to display plot") + <*> option auto ( + metavar "MPTCP" + -- internal is stronger than --belive, hides from all descriptions + <> internal + <> Options.Applicative.value mptcpPlot + <> help "" + ) + + +-- | +-- @param +-- TODO specialize ArgsPlots for TCP ? +piPlotTcpMainParser :: ParserInfo CommandArgs +piPlotTcpMainParser = info parserPlotTcpMain + ( progDesc " TCP Plots" + ) + + +-- +parserLivePlotTcpSettings :: Parser LivePlotTcpSettings +parserLivePlotTcpSettings = LivePlotTcpSettings <$> + parserConnection + <*> optional (strOption + ( long "fake" <> short 'f' + <> help "Load data from a pcap. This is used only for testing." + <> completer completePath + <> metavar "PCAP" )) + <*> optional (parserDestinationRole) + <*> strArgument ( + metavar "interface" <> help "interface to monitor" + -- TODO fetch list of interfaces in advance ! + <> completeWith ["eno1"] + ) + +-- loadConnectionsFromFile +plotLiveFilter :: Parser ArgsPlots +plotLiveFilter = ArgsPlotLiveTcp <$> parserLivePlotTcpSettings + + +-- |Helper to load an IP +readIP :: ReadM IP +-- encode or decode available, IP has +readIP = eitherReader $ \arg -> case decode $ T.pack arg of + Just ip -> Right ip + _otherwise -> Left $ "Could not decode ip " ++ arg + +parserConnection :: Parser TcpConnection +parserConnection = TcpConnection <$> + argument readIP (metavar "CLIENT_IP" <> help "Client IP (v4 or v6)") + <*> argument readIP (metavar "SERVER_IP" <> help "Server IP (v4 or v6)") + <*> argument auto (metavar "CLIENT_PORT" <> help "Client port") + <*> argument auto (metavar "SERVER_PORT" <> help "Server port") + -- Stream id wont be used anyway + <*> pure (StreamId 0) + -- <*> strArgument ( metavar "interface" <> help "interface to monitor") + +parserPlotTcpLive :: Parser CommandArgs +parserPlotTcpLive = ArgsPlotGeneric <$> parserPlotSettings False + <*> (plotLiveFilter) + +parserPlotMptcpLive :: Parser CommandArgs +parserPlotMptcpLive = ArgsPlotGeneric <$> parserPlotSettings False + <*> (ArgsPlotLiveMptcp <$> parserLivePlotTcpSettings) + + +-- -> Bool -- ^ for mptcp yes or no +parserPlotTcpMain :: Parser CommandArgs +parserPlotTcpMain = ArgsPlotGeneric <$> parserPlotSettings False + <*> hsubparser ( + command "attr" (info (plotStreamParser validTcpAttributes False) + (progDesc "toto")) + <> command "owd" piPlotTcpOwd + ) + + +parserPlotMptcpMain :: Parser CommandArgs +parserPlotMptcpMain = ArgsPlotGeneric <$> parserPlotSettings True + <*> hsubparser ( + command "attr" (info (plotStreamParser validTcpAttributes True) + (progDesc "Plot MPTCP attribute (choose from ...)")) + <> command "owd" (info (plotParserOwd True) (progDesc "Plot MPTCP owd")) + ) + +-- piPlotTcpAttrParser :: ParserInfo ArgsPlots +-- piPlotTcpAttrParser = info (plotStreamParser validTcpAttributes False) +-- ( progDesc "Plot TCP attr" +-- ) + +-- | +-- @param +piPlotMptcpParser :: ParserInfo ArgsPlots +piPlotMptcpParser = info ( + plotStreamParser validMptcpAttributes True + ) + ( progDesc "Plot MPTCP attr" + ) + + +-- Superset of @validTcpAttributes@ +validMptcpAttributes :: [String] +validMptcpAttributes = validTcpAttributes +-- |Options that are available for all parsers +-- plotParserGenericOptions +-- TODO generate from the list of fields, via TH? + +validTcpAttributes :: [String] +validTcpAttributes = map T.unpack (Map.keys $ Map.mapMaybe tfieldLabel baseFields) + + +validateField :: [String] -> ReadM String +validateField validFields = eitherReader $ \arg -> if elem arg validFields then + Right arg + else Left $ validationErrorMsg validFields arg + +validationErrorMsg :: [String] -> String -> String +validationErrorMsg validFields entry = "validatedField: incorrect value `" ++ entry ++ "` choose from:\n -" ++ intercalate "\n - " validFields + + +parserDestinationRole :: Parser ConnectionRole +parserDestinationRole = argument readConnectionRole ( + metavar "Destination" + -- <> Options.Applicative.value RoleServer + <> help "Only show in a specific direction" + <> completeWith ["server", "client"] + ) + +-- TODO pass the list of accepted attributes (so that it works for TCP/MPTCP) +plotStreamParser :: + [String] + -- ^ List of TCP attribute names + -> Bool -- ^ for mptcp yes or no + -> Parser ArgsPlots +plotStreamParser _validAttributes mptcpPlot = ArgsPlotTcpAttr <$> + -- this ends up being not optional ! + -- argument (validateField _validAttributes) ( + -- metavar "FIELD" + -- <> help ( "Field to plot (choose from " ++ (intercalate ", " _validAttributes) ++ ")") + -- ) + strArgument ( + metavar "PCAP" + <> help "File to analyze" + ) + <*> argument auto ( + metavar "STREAM_ID" + <> help "Stream Id (tcp.stream)" + ) + -- TODO validate as presented in https://github.com/pcapriotti/optparse-applicative/issues/75 + <*> argument (validateField _validAttributes) ( + metavar "TCP_ATTR" + <> help ("A TCP attr in the list: " <> (unlines validTcpAttributes)) + <> completeWith _validAttributes + ) + -- TODO ? if nothing prints both directions + <*> optional (parserDestinationRole) + <**> helper + +-- | A typeclass abstracting the functions we need +-- to be able to plot against an axis of type a +-- class Ord a => PlotValue a where +-- toValue :: a -> Double +-- fromValue:: Double -> a +-- autoAxis :: AxisFn a + +-- instance RealFloat Word32 where + +-- deriving instance PlotValue Word32 +instance PlotValue Word32 where + -- => toDouble + toValue = fromIntegral + -- => double -> value + fromValue = truncate . toRational + -- autoAxis = autoScaledAxis def + -- autoScaledAxis def + -- autoAxis = autoScaledIntAxis def + autoAxis = autoScaledIntAxis defaultIntAxis + +instance PlotValue Word64 where + -- => toDouble + toValue = fromIntegral + -- => double -> value + fromValue = truncate . toRational + -- autoAxis = autoScaledAxis def + -- autoScaledAxis def + -- autoAxis = autoScaledIntAxis def + autoAxis = autoScaledIntAxis defaultIntAxis + +-- called PlotTcpAttribute in mptcpanalyzer +-- todo pass --filterSyn Args fields +-- TODO filter according to destination + + +-- | Plots the selected attribute +-- ![image description](pathtoimage.png) + +cmdPlotTcpAttribute :: ( + Members [Log, P.State MyState, Cache, Embed IO] m + ) + => String -- ^Tcp attribute see @validTcpAttributes@ + -- -> FilePath -- ^ temporary file to save plot to + -> [ConnectionRole] + -> FrameFiltered TcpConnection Packet + -- we could return a EC r () instead + -> Sem m (EC (Layout Double Double) ()) +cmdPlotTcpAttribute field destinations aFrame = do + +-- inCore converts into a producer + -- embed $ putStrLn $ showConnection (ffTcpCon tcpFrame) + -- embed $ writeCSV "debug.csv" frame2 + -- TODO provide a nice label + -- TODO generate for mptcp plot + return $ do + layout_title .= "TCP " ++ field + mapM_ plotAttr destinations + + -- return Continue + where + -- filter by dest + frame2 = addTcpDestinationsToAFrame aFrame + -- plotAttr :: ( PlotValue y) => ConnectionRole -> EC (Layout Double y) () + plotAttr dest = + plot (line ("TCP " ++ field ++ " (" ++ show dest ++ ")") [ [ (d,v) | (d,v) <- plotData ] ]) + -- plot (line ("TCP " ++ field ++ " (" ++ show dest ++ ")") [ my_data ]) + where + -- frameDest = ffTcpFrame tcpFrame + frameDest = frame2 + unidirectionalFrame = filterFrame (\x -> x ^. tcpDest == dest) (ffFrame frameDest) + + plotData :: [(Double, Double)] + plotData = getData (unidirectionalFrame') field + + -- we add a fake mptcpDest column to satisfy + unidirectionalFrame' = fmap (\x -> Col RoleServer :& x) unidirectionalFrame + -- (timeData, seqData) = plotData + + +-- it should be possible to get something more abstract +getData :: + -- RecElem + -- Rec TcpLen TcpLen rs rs (Data.Vinyl.TypeLevel.RIndex TcpLen rs), + -- (Record HostCols) <: (Record rs) + -- Foldable t, Functor t + FrameRec (MptcpDest ': TcpDest ': HostCols) -> String -> [(Double, Double)] +getData frame attr = + getAttr + where + -- timeData :: [Double] + timeData = F.toList $ view relTime <$> frame + + getAttr = case attr of + "tcpSeq" -> [ (t, v) | (t, v) <- zip timeData (getTcpData tcpSeq) ] + -- "tcpLen" -> fromIntegral. view tcpLen + -- "rwnd" -> fromIntegral. view rwnd + -- "tcpAck" -> fromIntegral. view tcpAck + -- "tsval" -> tsval + "mptcpDsn" -> getMptcpData frame mptcpDsn + "mptcpDack" -> getMptcpData frame mptcpDack + + _ -> error "unsupported attr" + + -- getTcpData t (Record (TcpDest ': HostCols) ) :: + -- getTcpData frame' getter = F.toList $ (fromIntegral . view getter) <$> frame' + + getTcpData getter = F.toList ((fromIntegral . view getter) <$> frame) + +getMptcpData :: _ +getMptcpData frame getter = + [ (t, v) | (t, v) <- zip timeData values ] + -- (timeData, view relTime <$> justFrame) + where + timeData = F.toList $ view relTime <$> justFrame + values = fmap fromIntegral $ catMaybes $ F.toList $ (view getter) <$> justFrame + -- filter on the field + justFrame = filterFrame (\x -> isJust $ x ^. getter) frame + + +-- | Plot an attribute selected from '' +-- @TODO support more attributes +cmdPlotMptcpAttribute :: ( + Members [ + Log, P.State MyState, P.Trace, Cache, Embed IO + ] m) => String -- ^ mptcp attr + -> FilePath -- ^ temporary file to save plot to + -> [ConnectionRole] + -> FrameFiltered MptcpConnection Packet + -> Sem m RetCode +cmdPlotMptcpAttribute field tempPath destinations aFrame = do + +-- inCore converts into a producer + Log.debug $ "show con " <> tshow (ffCon aFrame) + P.trace $ T.unpack $ showConnectionText (ffCon aFrame) + P.trace $ "number of packets" ++ show (frameLength (ffFrame aFrame)) + -- TODO remove + embed $ writeCSV "debug.csv" (ffFrame aFrame) + embed $ writeCSV "dest.csv" frameDest + embed $ toFile def tempPath $ do + layout_title .= "MPTCP " ++ field + -- TODO generate for mptcp plot + -- for each subflow, plot the MptcpDest + mapM_ plotAttr ( [ (dest, con) | dest <- destinations , con <- Set.toList $ _mpconSubflows $ ffCon aFrame ]) + -- mapM_ plotAttr destinations + + return Continue + where + -- add dest to the whole frame + frameDest = addMptcpDest (ffFrame aFrame) (ffCon aFrame) + plotAttr (dest, sf) = + -- plot (line lineLabel [ [ (d,v) | (d,v) <- zip timeData seqData ] ]) + plot (line lineLabel [ frameData ]) + where + -- frameData :: ([Double], [ + -- strip down + frameData = getData unidirectionalFrame field + -- show sf + lineLabel = "subflow " ++ show (conTcpStreamId (sfConn sf)) ++ " seq (" ++ show dest ++ ")" + -- frameDest = frame2 + unidirectionalFrame = filterFrame (\x -> x ^. mptcpDest == dest + && x ^. tcpStream == conTcpStreamId (sfConn sf) ) frameDest + + -- seqData :: [Double] + -- seqData = map fromIntegral (F.toList $ view tcpSeq <$> unidirectionalFrame) + -- timeData = traceShow ("timedata" ++ show (frameLength unidirectionalFrame)) F.toList $ view relTime <$> unidirectionalFrame + + diff --git a/src/MptcpAnalyzer/Commands/PlotOWD.hs b/src/MptcpAnalyzer/Commands/PlotOWD.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Commands/PlotOWD.hs @@ -0,0 +1,327 @@ +{- +Module : MptcpAnalyzer.Commands.PlotOwd +Description : Plot One way delays +Maintainer : matt +-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module MptcpAnalyzer.Commands.PlotOWD ( + cmdPlotTcpOwd + , cmdPlotMptcpOwd + , plotParserOwd + , piPlotTcpOwd +) +where + +import MptcpAnalyzer.ArtificialFields +import MptcpAnalyzer.Cache +import MptcpAnalyzer.Commands.Definitions +import MptcpAnalyzer.Commands.Definitions as CMD +import MptcpAnalyzer.Debug +import MptcpAnalyzer.Loader +import MptcpAnalyzer.Merge +import MptcpAnalyzer.Pcap +import MptcpAnalyzer.Plots.Types +import MptcpAnalyzer.Stream +import MptcpAnalyzer.Types +import MptcpAnalyzer.Utils.Text +-- for retypeColumn +-- import MptcpAnalyzer.Frames.Utils +-- for fields +import Net.Mptcp +import Net.Tcp + +import Frames +import qualified Frames as F +import Frames.CSV +import Options.Applicative +import Polysemy +import qualified Polysemy.Trace as P +import Prelude hiding (filter, log, lookup, repeat) + +-- import Graphics.Rendering.Chart.Backend.Diagrams (defaultEnv, runBackendR) +-- import Graphics.Rendering.Chart.Easy + +import Data.Word (Word16, Word32, Word64, Word8) +import Graphics.Rendering.Chart.Backend.Cairo +import Graphics.Rendering.Chart.Easy hiding (argument) + +import Data.Vinyl.TypeLevel as V + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Pipes as P hiding (embed) +import qualified Pipes.Prelude as P +import Polysemy (Embed, Member, Members, Sem) +import qualified Polysemy as P +import Polysemy.State as P +import System.Exit +import System.Process hiding (runCommand) +-- import Data.Time.LocalTime +import Data.Foldable (toList) +import Data.Maybe (catMaybes, fromMaybe) +import qualified Data.Set as Set +import Debug.Trace +import Distribution.Simple.Utils (TempFileOptions(..), withTempFileEx) +import Frames.ShowCSV (showCSV) +import GHC.TypeLits (Symbol) +import Polysemy.Log (Log) +import qualified Polysemy.Log as Log +import System.Directory (renameFile) +import System.IO (Handle) +import Tshark.Main (defaultTsharkPrefs) + +-- data PlotTypes = PlotTcpAttribute { +-- pltAttrField :: Text +-- -- syndrop => drop syn packets +-- -- Drops first 3 packets of the dataframe assuming they are syn +-- } + +-- Plot MPTCP subflow attributes over time + +-- piPlotParserTcpAttr :: Parser PlotTypes +-- piPlotParserTcpAttr = PlotTcpAttribute <$> argument str +-- ( help "Choose an mptcp attribute to plot" +-- <> metavar "FIELD" ) + +-- | +-- @param +piPlotTcpOwd :: ParserInfo ArgsPlots +piPlotTcpOwd = info (plotParserOwd False) (progDesc "Plot TCP owd") + + + +-- TODO pass the list of accepted attributes (so that it works for TCP/MPTCP) +plotParserOwd :: + -- [String] + Bool -- ^ for mptcp yes or no + -> + Parser ArgsPlots +plotParserOwd _mptcpPlot = ArgsPlotOwdTcp <$> + parserPcapMapping False + -- this ends up being not optional ! + -- strArgument ( + -- metavar "PCAP1" + -- <> help "File to analyze" + -- ) + -- <*> strArgument ( + -- metavar "PCAP2" + -- <> help "File to analyze" + -- ) + -- -- auto readStreamId + -- <*> argument auto ( + -- metavar "STREAM_ID1" + -- <> help "Stream Id (tcp.stream)" + -- ) + -- <*> argument auto ( + -- metavar "STREAM_ID2" + -- <> help "Stream Id (tcp.stream)" + -- ) + -- TODO validate as presented in https://github.com/pcapriotti/optparse-applicative/issues/75 + --validate :: (a -> Either String a) -> ReadM a -> ReadM a + -- TODO ? if nothing prints both directions + <*> optional (argument readConnectionRole ( + metavar "Destination" + -- <> Options.Applicative.value RoleServer + <> help "" + )) + -- <**> help + -- <*> option auto ( + -- metavar "MPTCP" + -- -- internal is stronger than --belive, hides from all descriptions + -- <> internal + -- <> Options.Applicative.value mptcpPlot + -- <> help "" + -- ) + +-- called PlotTcpAttribute in mptcpanalyzer +-- todo pass --filterSyn Args fields +-- TODO filter according to destination + +-- destinations is an array of destination +-- cmdPlotTcpAttribute :: Members [Log String, P.State MyState, Cache, Embed IO] m => +-- FilePath -- ^ temporary file to save plot to +-- -> Handle +-- -> [ConnectionRole] +-- -> FrameFiltered Packet +-- -> Sem m RetCode +-- cmdPlotTcpAttribute tempPath _ destinations aFrame = do + +-- -- inCore converts into a producer +-- -- embed $ putStrLn $ showConnection (ffTcpCon tcpFrame) +-- -- embed $ writeCSV "debug.csv" frame2 +-- embed $ toFile def tempPath $ do +-- layout_title .= "TCP Sequence number" +-- -- TODO generate for mptcp plot +-- flip mapM_ destinations plotAttr + +-- return Continue +-- where +-- -- filter by dest +-- frame2 = addTcpDestinationsToAFrame aFrame +-- plotAttr dest = +-- plot (line ("TCP seq (" ++ show dest ++ ")") [ [ (d,v) | (d,v) <- zip timeData seqData ] ]) +-- where +-- -- frameDest = ffTcpFrame tcpFrame +-- frameDest = frame2 +-- -- frameDest = frame2 +-- unidirectionalFrame = filterFrame (\x -> x ^. tcpDest == dest) (ffFrame frameDest) + +-- seqData :: [Double] +-- seqData = map fromIntegral (toList $ view tcpSeq <$> unidirectionalFrame) +-- timeData = toList $ view relTime <$> unidirectionalFrame + +-- AbsTime2 +-- type AbsTime2 = "absTime2" :-> Text -- :: (Symbol, *) + +-- absTime2 is problematic +-- declareColumn "absTime2" ''Text +-- declareColumn "absTimeSnd" ''Double +-- type AbsTime2 = "absTime2" :-> Text -- :: (Symbol, *) +-- expects (Symbol, Symbol, Type) +-- type AbsTimeRenameTest = ("absTime" :: Symbol, "absTime2", Text) + +-- type RetypeMatt = [ +-- ("absTime", "absTime2", Text) +-- ] + +cmdPlotTcpOwd :: (Members [Log, P.Trace, P.State MyState, Cache, Embed IO] m) + => FilePath -- ^ temporary file to save plot to + -> Handle + -> [ConnectionRole] + -- -> TcpConnection + -> (PcapMapping Tcp) + -- -> MergedFrame + -- -> FrameFiltered Packet + -- -> FrameFiltered (Record HostColsPrefixed) + -> Sem m RetCode +cmdPlotTcpOwd tempPath _ destinations (PcapMapping pcap1 streamId1 pcap2 streamId2) = do + Log.info "plotting TCP OWDs " + -- look at https://hackage.haskell.org/package/vinyl-0.13.0/docs/Data-Vinyl-Functor.html#t::. + -- could use showRow as well + -- P.embed $ dumpRec $ head justRecs + -- P.trace $ "There are " ++ show (length justRecs) ++ " valid merged rows (out of " ++ show (length mergedRes) ++ " merged rows)" + -- P.trace $ (concat . showFields) (head justRecs) + -- P.embed $ putStrLn $ "retyped column" ++ (concat . showFields) (newCol) + Log.info $ "plotting owd for tcp.stream " <> tshow streamId1 <> " and " <> tshow streamId2 + eframe1 <- buildAFrameFromStreamIdTcp defaultTsharkPrefs pcap1 streamId1 + eframe2 <- buildAFrameFromStreamIdTcp defaultTsharkPrefs pcap2 streamId2 + + res <- case (eframe1, eframe2 ) of + (Left err, _) -> return $ CMD.Error err + (_, Left err) -> return $ CMD.Error err + (Right (FrameTcp con frame1), Right aframe2) -> do + -- TODO addTcpDest -> convert then + let + dest = genTcpDestFrame frame1 con + + convertCols' :: Record '[TcpDest] -> Record '[SenderDest] + convertCols' = F.withNames . F.stripNames + sendFrame = fmap convertCols' dest + + mergedRes <- mergeTcpConnectionsFromKnownStreams (FrameTcp con (F.zipFrames sendFrame frame1)) aframe2 + -- let mbRecs = map recMaybe mergedRes + -- let justRecs = catMaybes mbRecs + let sndRcvFrame = convertToSenderReceiver mergedRes + + embed $ toFile def tempPath $ do + layout_title .= "TCP One-way delays" + -- TODO generate for mptcp plot + -- for each subflow, plot the MptcpDest + mapM_ (plotAttr sndRcvFrame) [ x | x <- destinations] + + + -- embed $ putStrLn $ showConnection (ffTcpCon tcpFrame) + -- embed $ writeDSV defaultParserOptions "tcp-owd-debug.csv" (toFrame justRecs) + embed $ writeDSV defaultParserOptions "tcp-owd-converted.csv" sndRcvFrame + -- P.embed $ putStrLn $ "OWDs:" ++ show owd + -- so for now we assume an innerJoin (but fix it later) + return Continue + where + -- mbRecs = map recMaybe mergedRes + -- justRecs = catMaybes mbRecs + dumpRec x = print x + -- add dest to the whole frame + -- frameDest = addMptcpDest (ffFrame aFrame) (ffCon aFrame) + plotAttr sndRcvFrame dest = + plot (line lineLabel [ [ (d,v) | (d,v) <- zip timeData owd ] ]) + + where + lineLabel = "TCP seq " ++ showConnection con ++ " (towards " ++ showConnectionRole dest ++ ")" + unidirectionalFrame = filterFrame (\x -> x ^. senderDest == dest) sndRcvFrame + + timeData = traceShow ("timedata length=" ++ show (frameLength unidirectionalFrame)) toList $ view sndAbsTime <$> unidirectionalFrame + + getOwd x = (x ^. rcvAbsTime) - (x ^. sndAbsTime) + + owd :: [Double] + owd = let res = map getOwd (toList unidirectionalFrame) in traceShow res res + return res + + + + +cmdPlotMptcpOwd :: ( + Members [Log, P.Trace, P.State MyState, Cache, Embed IO] m) + => FilePath -- ^ temporary file to save plot to + -> Handle + -> [ConnectionRole] + -> TcpConnection + -> MergedFrame + -> Sem m RetCode +cmdPlotMptcpOwd tempPath _ destinations con mergedRes = do + Log.info "plotting MPTCP OWDs " + -- look at https://hackage.haskell.org/package/vinyl-0.13.0/docs/Data-Vinyl-Functor.html#t::. + -- could use showRow as well + -- P.embed $ dumpRec $ head justRecs + -- P.trace $ "There are " ++ show (length justRecs) ++ " valid merged rows (out of " ++ show (length mergedRes) ++ " merged rows)" + -- P.trace $ (concat . showFields) (head justRecs) + -- P.embed $ putStrLn $ "retyped column" ++ (concat . showFields) (newCol) + embed $ toFile def tempPath $ do + layout_title .= "MPTCP One-way delays" + -- TODO generate for mptcp plot + -- for each subflow, plot the MptcpDest + mapM_ plotAttr [ x | x <- destinations] + + + -- embed $ putStrLn $ showConnection (ffTcpCon tcpFrame) + -- embed $ writeDSV defaultParserOptions "mptcp-owd-debug.csv" (toFrame justRecs) + embed $ writeDSV defaultParserOptions "mptcp-owd-converted.csv" sndRcvFrame + -- P.embed $ putStrLn $ "OWDs:" ++ show owd + -- so for now we assume an innerJoin (but fix it later) + + return Continue + where + -- mbRecs = map recMaybe mergedRes + -- justRecs = catMaybes mbRecs + sndRcvFrame = convertToSenderReceiver mergedRes + dumpRec x = print x + -- add dest to the whole frame + -- frameDest = addMptcpDest (ffFrame aFrame) (ffCon aFrame) + plotAttr dest = + plot (line lineLabel [ [ (d,v) | (d,v) <- zip timeData owd ] ]) + + where + lineLabel = "Subflow DSNs " ++ showConnection con ++ " (towards " ++ showConnectionRole dest ++ ")" + unidirectionalFrame = filterFrame (\x -> x ^. senderDest == dest) sndRcvFrame + + timeData = traceShow ("timedata length=" ++ show (frameLength unidirectionalFrame)) toList $ view sndAbsTime <$> unidirectionalFrame + + getOwd x = (x ^. rcvAbsTime) - (x ^. sndAbsTime) + + owd :: [Double] + owd = let res = map getOwd (toList unidirectionalFrame) in traceShow res res + + diff --git a/src/MptcpAnalyzer/Commands/Reinjections.hs b/src/MptcpAnalyzer/Commands/Reinjections.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Commands/Reinjections.hs @@ -0,0 +1,337 @@ +{-| + +Module : MptcpAnalyzer.Commands.Reinjections +Description : Command to analyze reinjections +Maintainer : matt + + +-} +{-# LANGUAGE PackageImports #-} +module MptcpAnalyzer.Commands.Reinjections ( + + piListReinjections + , piQualifyReinjections + , qualifyReinjections + , cmdListReinjections + , cmdQualifyReinjections +) +where + +import MptcpAnalyzer.ArtificialFields +import MptcpAnalyzer.Cache +import MptcpAnalyzer.Commands.Definitions as CMD +import MptcpAnalyzer.Commands.List as CMD +import MptcpAnalyzer.Loader +import MptcpAnalyzer.Merge +import MptcpAnalyzer.Pcap +import MptcpAnalyzer.Stream +import MptcpAnalyzer.Types +import Net.Mptcp + +import Control.Lens ((^.)) +import Control.Lens hiding (argument) +import Data.Either (lefts, rights) +import Data.Foldable (toList) +import qualified Data.Foldable as F +import Data.Function (on) +import Data.List (intercalate, intersperse, sortBy, sortOn) +import Data.Maybe +import Frames +import Frames.CSV +import Frames.Rec +import Options.Applicative +import qualified Pipes +import qualified Pipes.Prelude as Pipes +import Polysemy (Embed, Member, Members, Sem) +import qualified Polysemy as P +import Polysemy.Log (Log) +import qualified Polysemy.Log as Log +import Polysemy.State as P +import Polysemy.Trace as P +import Prelude hiding (log) + +import Control.Monad +import qualified Debug.Trace as D +import Tshark.Main (defaultTsharkPrefs) + +piListReinjections :: ParserInfo CommandArgs +piListReinjections = info ( + parserListReinjections + <**> helper) + ( progDesc "List MPTCP reinjections" + ) + where + -- parserListReinjections :: Parser CommandArgs + parserListReinjections = + ArgsListReinjections <$> + -- strArgument ( + -- metavar "PCAP1" + -- <> help "File to analyze" + -- ) + -- <*> + argument readStreamId ( + metavar "TCP_STREAM" + <> help "stream id to analyze" + ) + +piQualifyReinjections :: ParserInfo CommandArgs +piQualifyReinjections = info ( + parserQualifyReinjections <**> helper) + ( progDesc "Qualifies MPTCP reinjections" + <> footer "analyze examples/client_2_redundant.pcapng 0 examples/server_2_redundant.pcapng 0" + ) + + +parserQualifyReinjections :: Parser CommandArgs +parserQualifyReinjections = + ArgsQualifyReinjections + <$> parserPcapMapping False + <*> switch ( + long "verbose" + <> help "Verbose or not" + ) + +cmdListReinjections :: (Members '[Log, P.Trace, P.State MyState, Cache, Embed IO] r) + => StreamId Mptcp + -> Sem r RetCode +cmdListReinjections streamId = do + state <- P.get + let loadedPcap = view loadedFile state + case loadedPcap of + Nothing -> do + trace "please load a pcap first" + return CMD.Continue + Just (frame :: FrameRec HostCols) -> do + let + reinjectedPacketsFrame = filterFrame (\x -> isJust $ x ^. reinjectionOf) frame + -- log $ "Number of rows " ++ show (frameLength frame) + outputs = fmap showReinjections reinjectedPacketsFrame + -- P.embed $ putStrLn $ "Number of MPTCP connections " ++ show (length mptcpStreams) + -- P.embed $ putStrLn $ show mptcpStreams + P.trace $ intercalate "\n" (toList outputs) + return CMD.Continue + where + -- packetid=757 (tcp.stream 1) is a reinjection of 1 packet(s): + -- - packet 256 (tcp.stream 7) + showReinjections row = "packetid=" ++ show (row ^. packetId) ++ " (tcp.stream " ++ show (row ^. tcpStream) ++ ")\n" + -- TODO map over the list + ++ intercalate "\n" ( map showReinjection (fromJust $ row ^. reinjectionOf)) + + showReinjection reinjection = case toList $ filterFrame (\x -> x ^. packetId == reinjection) (frame) of + [] -> error "did not find original packet" + rows -> "- Reinjection of " ++ show reinjection ++ "(tcp.stream " ++ show ( (head rows) ^. tcpStream) ++ ")" + +-- Analyzes row of reinject packets +-- Compares arrival time of the first send of a segment with the +analyzeReinjection :: FrameRec SenderReceiverCols -> Record SenderReceiverCols -> Double +analyzeReinjection mergedFrame row = + let + -- a list of packetIds + reinjectOf = fromJust (rgetField @SndReinjectionOf row) + initialPktId = D.traceShowId $ head reinjectOf + + -- it is a frame + + originalPkt :: Record SenderReceiverCols + originalPkt = let + originalFrame = filterFrame (\x -> x ^. sndPacketId == initialPktId) mergedFrame + in case frameLength originalFrame of + 0 -> error "empty frame" + _ -> frameRow originalFrame 0 + + origArrival, reinjArrival :: Double + origArrival = rgetField @RcvRelTime originalPkt + reinjArrival = rgetField @RcvRelTime originalPkt + reinjPktId = row ^. sndPacketId + + delta = reinjArrival - origArrival + in + delta + + +{- Tries to distinguish between useful and useless reinjections + Also tries to evalute the usefulness by providing a delta showing how much time + the reinjection made the connection win or lose +-} +cmdQualifyReinjections :: + Members '[ + Log + , P.State MyState + , Cache + , P.Trace + , Embed IO + ] r + => PcapMapping Mptcp + -> [ConnectionRole] + -> Bool + -> Sem r RetCode +cmdQualifyReinjections (PcapMapping pcap1 streamId1 pcap2 streamId2) destinations verbose = do + eframe1 <- buildAFrameFromStreamIdMptcp defaultTsharkPrefs pcap1 streamId1 + eframe2 <- buildAFrameFromStreamIdMptcp defaultTsharkPrefs pcap2 streamId2 + res <- case (eframe1, eframe2 ) of + (Right aframe1, Right aframe2) -> do + + mergedRes <- mergeMptcpConnectionsFromKnownStreams aframe1 aframe2 + let + -- mergedRes = mergeMptcpConnectionsFromKnownStreams' aframe1 aframe2 + reinjectedPacketsHost1 = filterFrame (\x -> isJust $ x ^. reinjectionOf) (ffFrame aframe1) + reinjectedPacketsHost2 = filterFrame (\x -> isJust $ x ^. reinjectionOf) (ffFrame aframe2) + + -- mbRecs = map recMaybe mergedRes + -- packets that could be mapped in both pcaps + -- justRecs = catMaybes mbRecs + myFrame = convertToSenderReceiver mergedRes + + reinjectedPacketsFrame = filterFrame (\x -> isJust $ x ^. sndReinjectionOf) myFrame + + -- loop over these reinjectpackets + -- assume both were mapped + + -- Log.info $ "Result of the analysis; reinjections:" + -- <> tshow (showReinjects justRecs) + -- Log.debug $ "reinjectionsOf in host1 frame " <> tshow $ showFrame myFrame + -- Log.debug $ "showing merged res" <> tshow (showMergedRes $ take 3 mergedRes) + -- P.embed $ writeMergedPcap ("mergedRes-" ++ ".csv") mergedRes + trace $ "Size after conversion to sender/receiver " ++ show (frameLength myFrame) + ++ "( " ++ show (length mergedRes) ++ ")" + -- trace $ "Number of reinjected packets: " ++ show (frameLength reinjectedPacketsFrame) + + -- trace $ "Merged mptcp connection\nFrame size: " ++ show (frameLength reinjectedPacketsFrame) + -- ++ "\n" ++ showFrame "," reinjectedPacketsFrame + forM_ destinations $ \x -> do + qualifyReinjections myFrame (assignRoles aframe1 aframe2) x + + -- qualifyReinjections tempPath handle (getDests dest) (ffCon aframe1) mergedRes + return CMD.Continue + (Left err, _) -> return $ CMD.Error err + (_, Left err) -> return $ CMD.Error err + + + return CMD.Continue + -- mergedPcap + -- reinjectedPackets = filterFrame (sndReinjectionOf) (toFrame justRecs) + +-- buildTcpConnectionFromSndRecord :: ( +-- SndIpSource ∈ rs, SndIpDest ∈ rs, SndTcpSrcPort ∈ rs, SndTcpDestPort ∈ rs, SndTcpStream ∈ rs +-- -- rs ⊆ HostCols +-- ) +-- => Record rs -> TcpConnection +-- buildTcpConnectionFromRecord r = +-- TcpConnection { +-- conTcpClientIp = r ^. sndIpSource +-- , conTcpServerIp = r ^. sndIpDest +-- , conTcpClientPort = r ^. sndTcpSrcPort +-- , conTcpServerPort = r ^. sndTcpDestPort +-- , conTcpStreamId = r ^. sndTcpStream +-- } + + +-- buildConnectionFromSndPacket :: Record SenderReceiverCols -> TcpConnection +-- buildConnectionFromSndPacket row -> + + +-- | Returns (Client,Server) +-- kinbda hackish +assignRoles :: FrameFiltered MptcpConnection Packet -> FrameFiltered MptcpConnection Packet + -> (FrameFiltered MptcpConnection Packet , FrameFiltered MptcpConnection Packet) +assignRoles aframe1 aframe2 = + if delta > 0 then + (aframe1, aframe2) + else + (aframe2, aframe1) + where + -- assume non empty + firstRow1 = frameRow (ffFrame aframe1) 0 + firstRow2 = frameRow (ffFrame aframe2) 0 + + delta :: Double + delta = (firstRow2 ^. absTime) - (firstRow1 ^. absTime) + + -- selectDest :: ConnectionRole -> FrameRec MergedHostCols + -- selectDest dest = (filterFrame (\x -> x ^. senderDest == dest) jframe) + + +-- TODO there should be a classification on a per mptcp basis +-- Here we should be able to tell who is the sender +qualifyReinjections :: Members '[ + Log, P.State MyState + , Cache + , P.Trace + , Embed IO + ] r + => FrameRec SenderReceiverCols + -- (Client, server) pcaps + -> (FrameFiltered MptcpConnection Packet,FrameFiltered MptcpConnection Packet) + -> ConnectionRole + -> Sem r () +qualifyReinjections frame (aframeH1, aframeH2) dest = do + let + -- "dest"frame + dstFrame = filterFrame (\x -> x ^. senderDest == dest) frame + -- mergedRes = mergeMptcpConnectionsFromKnownStreams' aframe1 aframe2 + -- reinjectedPacketsHost1 = filterFrame (\x -> isJust $ x ^. reinjectionOf) (ffFrame aframe1) + -- reinjectedPacketsHost2 = filterFrame (\x -> isJust $ x ^. reinjectionOf) (ffFrame aframe2) + reinjectedPacketsFrame = filterFrame (\x -> isJust $ x ^. sndReinjectionOf) dstFrame + reinjects = fmap (analyzeReinjection frame) reinjectedPacketsFrame + + trace $ "Qualify reinjections for dests " ++ show dest + P.embed $ writeDSV defaultParserOptions ("sndrcv-merged-" ++ show dest ++ ".csv") dstFrame + trace $ "Number of reinjected packets: " ++ show (frameLength reinjectedPacketsFrame) + -- trace $ "Result of the analysis; reinjections:" ++ showReinjects reinjects + forM_ reinjectedPacketsFrame $ \row -> do + let + reinjectOf = fromJust (rgetField @SndReinjectionOf row) + hostType = rgetField @SenderHost row + senderDestVal = rgetField @SenderDest row + + -- originalFrame = if senderDest == RoleClient then (ffFrame aframeH2) else (ffFrame aframeH1) + originalFrame = frame + + -- should be only one + originalPackets = filterFrame (\x -> x ^. sndPacketId == initialPktId) originalFrame + + -- ((frameRow originalPacket 0) ^. senderHost) + hostBool = if frameLength originalPackets > 0 then show hostType else "unknown" + + -- TODO we want to find + -- buildTcpConnectionFromSndRecord + + initialPktId = D.traceShowId $ head reinjectOf + -- initialPktId = D.traceShowId $ head reinjectOf + -- of packet id " ++ show initialPktId + -- from host" ++ show hostType + trace $ show (row ^. sndPacketId) ++ " is a reinjection of packet id " ++ show initialPktId + trace $ "number of original packets " ++ show (frameLength originalPackets) ++ " Host " ++ show senderDestVal + trace $ describeReinjection row originalPackets + -- TODO check if pktId is available + + where + showReinjects frame2 = + -- unlines (intercalate sep (columnHeaders (Proxy :: Proxy (Record rs))) : rows) + intercalate "," rows + where + rows = Pipes.toList (F.mapM_ (Pipes.yield . show ) frame2) + + describeReinjection reinjectedPacket originalPackets = case frameLength originalPackets of + 0 -> "No original packets found FISHY ?!" + _otherwise -> let + originalPacket = frameRow originalPackets 0 + reinjArrivalTime = reinjectedPacket ^. rcvAbsTime + originalArrivalTime = originalPacket ^. rcvAbsTime + reinj_delta = reinjArrivalTime - originalArrivalTime + + in + if reinj_delta < 0 then + "Efficient reinjection: latency gain: " ++ show reinj_delta + + else + "Redundant reinjection" ++ show reinj_delta + -- + + -- # print("GOT A failed reinjection") + -- df_all.loc[df_all[_sender("packetid")] == reinjection.packetid, "redundant"] = True + -- #TODO set reinj_delta for reinjection.packetid + -- else: + -- # print("GOT a successful reinjection") + -- pass + diff --git a/src/MptcpAnalyzer/Debug.hs b/src/MptcpAnalyzer/Debug.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Debug.hs @@ -0,0 +1,53 @@ +{-| +Module : MptcpAnalyzer.Merge +Description : Utilities to help debug +Maintainer : matt +License : GPL-3 +-} +module MptcpAnalyzer.Debug +where + +import Data.Proxy +import Data.Vinyl +import Frames +import Frames.CSV +-- import Data.Text +import Data.List (intercalate) + +{- +check: + - showFrame + - printFrame +from Frames.Exploration too +-} + +-- pipeToCSV +-- see https://github.com/acowley/Frames/issues/130 +showRow :: (RecMapMethod Show ElField a, RecordToList a) + => (Record a) -> String +showRow row = intercalate "\t" $ showFields row + +showHeader :: forall a . (ColumnHeaders a) => Frame (Record a) -> String +showHeader frame = intercalate "\t" $ columnHeaders (Proxy :: Proxy (Record a)) + +viewFrame :: (RecMapMethod Show ElField a, RecordToList a, ColumnHeaders a) + => Frame (Record a) -> IO () +viewFrame frame = do + putStrLn $ showHeader frame + mapM_ (putStrLn . showRow) frame + +-- writeMergedPcap :: FilePath -> MergedPcap -> IO () +-- writeMergedPcap outPath mergedPcap = do +-- -- showReinjects frame = +-- -- unlines (intercalate sep (columnHeaders (Proxy :: Proxy (Record rs))) : rows) +-- writeFile outPath content +-- where +-- content = intercalate "," rows +-- rows = Pipes.toList (F.mapM_ (Pipes.yield . show ) mergedPcap) + + + + + +-- +-- embed $ writeCSV "debug.csv" (ffFrame aFrame) diff --git a/src/MptcpAnalyzer/Frame.hs b/src/MptcpAnalyzer/Frame.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Frame.hs @@ -0,0 +1,65 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} +{-| +Description : +Maintainer : matt +Stability : testing +Portability : Linux +-} +module MptcpAnalyzer.Frame () +where + +import MptcpAnalyzer.Types +-- import Tshark.Main (defaultParserOptions) +import MptcpAnalyzer.Pcap (defaultParserOptions) + +import Data.ByteString as BS +import Data.ByteString.Lazy as LBS +import Data.ByteString.Lazy.UTF8 as BLU +import Data.Serialize +import Data.Text as T +import Data.Text.Encoding as TSE +import Data.Vinyl hiding (rget) +import Frames +import Frames.CSV hiding (consumeTextLines) +import Frames.ShowCSV +import Pipes ((>->)) +import qualified Pipes as P +import qualified Pipes.Parse as P +import qualified Pipes.Prelude as P +import qualified Pipes.Safe as P +import qualified Pipes.Safe.Prelude as Safe +import System.IO (Handle, IOMode(ReadMode, WriteMode)) +-- import Data.Proxy +import qualified Data.Vinyl as V +import qualified Data.Vinyl.Class.Method as V +import System.IO.Unsafe (unsafePerformIO) + + +-- convertToBs :: Frame (Record a) -> Put +-- convertToBs f = do +-- bs <- P.runSafeT . P.runEffect $ produceDSV defaultParserOptions f >-> P.map BLU.fromString +-- return bs + +newtype Test a = FrameRec a + +-- TODO here we want to put a bytestring +instance (ColumnHeaders rs, V.RecMapMethod Show ElField rs, V.RecordToList rs) => Serialize (Frame (Record rs)) where + -- putByteString + put f = do + -- (csvDelimiter defaultTsharkPrefs) + let bs = BLU.fromString $ showFrame "|" f + -- let bs = unsafePerformIO $ do + -- writeDSV defaultParserOptions tmpFile f + -- BS.readFile tmpFile + -- renvoie unit IO () + putByteString $ LBS.toStrict bs + -- where + -- tmpFile = "tmp.csv" + -- put f = undefined + get = undefined + +-- consumeTextLines :: P.MonadSafe m => FilePath -> P.Consumer BS.ByteString m r +-- consumeTextLines fp = Safe.withFile fp WriteMode $ \h -> +-- let loop = P.await >>= P.liftIO . BS.hPut h >> loop +-- in loop diff --git a/src/MptcpAnalyzer/Loader.hs b/src/MptcpAnalyzer/Loader.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Loader.hs @@ -0,0 +1,136 @@ +{-| +Module : MptcpAnalyzer.Loader +Description : Load pcap/csv into a @Frame@ +Maintainer : matt +License : GPL-3 +-} +module MptcpAnalyzer.Loader ( + loadPcapIntoFrame + , loadPcapIntoFrameNoCache + , buildAFrameFromStreamIdTcp + , buildAFrameFromStreamIdMptcp + ) +where +import MptcpAnalyzer.Cache +import MptcpAnalyzer.Frame +import MptcpAnalyzer.Pcap +import MptcpAnalyzer.Stream +import MptcpAnalyzer.Types +import MptcpAnalyzer.Utils.Text +import Tshark.Main + +import Control.Monad.Trans (liftIO) +import Distribution.Simple.Utils (TempFileOptions(..), withTempFileEx) +import Frames +import Frames.CSV +import qualified Frames.InCore +import Net.Mptcp +import Net.Tcp +import Polysemy (Embed, Members, Sem) +import Polysemy.State as P +import Prelude hiding (log) +import System.Exit (ExitCode(..)) + +import qualified Data.Vinyl as V +import qualified Data.Vinyl.Class.Method as V +import GHC.IO.Handle (hClose) +import Polysemy.Log (Log) +import qualified Polysemy.Log as Log + +loadPcapIntoFrameNoCache :: ( + Frames.InCore.RecVec a + , Frames.CSV.ReadRec a + , ColumnHeaders a + ) + => TsharkParams + -> FilePath + -> IO (Either String (FrameRec a)) +loadPcapIntoFrameNoCache params path = do + res <- liftIO $ withTempFileEx opts "/tmp" "mptcp.csv" $ \tmpPath handle -> do + res <- exportToCsv params path handle + case res of + (ExitSuccess, _ ) -> do + -- we have to close the handle else loadRows can't access the file ! + hClose handle + loaded <- loadRows tmpPath + return $ Right loaded + (exitCode, stdErr) -> return $ Left $ "Error happened " ++ show exitCode ++ "\n" ++ show stdErr + return res + where + opts :: TempFileOptions + opts = TempFileOptions False + +-- TODO return an Either or Maybe ? +-- return an either instead +loadPcapIntoFrame :: + (Frames.InCore.RecVec a + , Frames.CSV.ReadRec a + , ColumnHeaders a + , V.RecMapMethod Show ElField a, V.RecordToList a + , Members [Log, Cache, Embed IO ] m) + => TsharkParams + -> FilePath + -> Sem m (Either String (FrameRec a)) +loadPcapIntoFrame params path = do + Log.info $ "Start loading pcap " <> tshow path + x <- getCache cacheId + case x of + Right frame -> do + Log.debug $ tshow cacheId <> " in cache" + return $ Right frame + Left err -> do + Log.debug $ "cache miss: " <> tshow err + Log.debug "Calling tshark" + (tempPath , exitCode, stdErr) <- liftIO $ do + withTempFileEx opts "/tmp" "mptcp.csv" $ \tmpPath handle -> do + (exitCode, herr) <- exportToCsv params path handle + hClose handle + return (tmpPath, exitCode, herr) + + if exitCode == ExitSuccess + then do + Log.debug $ "exported to file " <> tshow tempPath + frame <- liftIO $ loadRows tempPath + Log.debug $ "Number of rows after loading " <> tshow (frameLength frame) + cacheRes <- putCache cacheId frame + -- use ifThenElse instead + if cacheRes then + Log.info "Saved into cache" + else + pure () + return $ Right frame + else do + Log.info $ "Error happened: " <> tshow exitCode + Log.info $ tshow stdErr + return $ Left stdErr + + where + cacheId = CacheId [path] "" "csv" + opts :: TempFileOptions + opts = TempFileOptions True + + +-- buildTcpFrameFromFrame +-- \ Build a frame with only packets belonging to @streamId@ +buildAFrameFromStreamIdTcp :: (Members [Log, Cache, Embed IO ] m) + => TsharkParams + -> FilePath + -> StreamId Tcp + -> Sem m (Either String (FrameFiltered TcpConnection Packet)) +buildAFrameFromStreamIdTcp params pcapFilename streamId = do + res <- loadPcapIntoFrame params pcapFilename + return $ case res of + Left err -> Left err + Right frame -> buildTcpConnectionFromStreamId frame streamId + +buildAFrameFromStreamIdMptcp :: (Members [Log, Cache, Embed IO ] m) + => TsharkParams + -> FilePath + -> StreamId Mptcp + -> Sem m (Either String (FrameFiltered MptcpConnection Packet)) +buildAFrameFromStreamIdMptcp params pcapFilename streamId = do + Log.debug ("Building frame for mptcp stream " <> tshow streamId) + res <- loadPcapIntoFrame params pcapFilename + return $ case res of + Left err -> Left err + Right frame -> buildMptcpConnectionFromStreamId frame streamId diff --git a/src/MptcpAnalyzer/Map.hs b/src/MptcpAnalyzer/Map.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Map.hs @@ -0,0 +1,107 @@ +{-| +Module : MptcpAnalyzer.Maps +Description : Maps Packets and Tcp streams between two frames +Maintainer : matt + + +Helper functions to map (mp)tcp.stream from one pcap to the one in another pcap. + +For MPTCP, the association of mptcp.stream is done by identifying the same sendkey +in both pcaps. +For TCP, there is a similarity score computed on (IP, port) numbers. This could be +improved for sure (by comparing number of packets and other fields). + +See "MptcpAnalyzer.Merge" +-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-} +module MptcpAnalyzer.Map ( + mapMptcpConnection + , mapTcpConnection + , mapSubflows + , showMptcpSubflowMapping +) +where + +import MptcpAnalyzer.Cache +import MptcpAnalyzer.Loader +import MptcpAnalyzer.Pcap +import MptcpAnalyzer.Stream +import MptcpAnalyzer.Types +import MptcpAnalyzer.Utils.Text +import Net.Mptcp +import Net.Tcp + +import Data.Either (lefts, rights) +import Data.Function (on) +import Data.List (sortBy, sortOn) +import Data.Ord +import qualified Data.Set as Set +import Data.Text (Text, intercalate, unlines) +import qualified Data.Text as T +import Frames +import Options.Applicative +import Polysemy (Embed, Member, Members, Sem) +import qualified Polysemy as P +import Polysemy.State as P +import Prelude hiding (log) + +type MptcpSubflowMapping = [(MptcpSubflow, [(MptcpSubflow, Int)])] + +-- data MptcpSubflowMapping + +-- | Returns +-- TODO we should sort the returned +mapSubflows :: MptcpConnection -> MptcpConnection -> MptcpSubflowMapping +mapSubflows con1 con2 = + -- map selectBest (mpconSubflows con1) + [ (sf1, scoreSubflows sf1) | sf1 <- Set.toList (_mpconSubflows con1) ] + where + -- select best / sortOn + scoreSubflows sf1 = sortOn (Data.Ord.Down . snd) $ + map (\sf -> (sf, similarityScore sf1 sf)) (Set.toList $ _mpconSubflows con2) + + +-- | show a mapping +showMptcpSubflowMapping :: MptcpSubflowMapping -> Text +showMptcpSubflowMapping m = + T.unlines $ map showOneSfMapping m + where + showOneSfMapping (ref, scores) = "Mappings for " <> showMptcpSubflowText ref <> ":\n" + <> (intercalate "\n-" $ map (\(sf, score) -> showMptcpSubflowText sf <> " SCORE: "<> tshow score) scores) + + +-- | Ranks the pairings between TCP streams of two different pcaps +-- Returns a list of +mapTcpConnection :: + -- Members '[Log String, P.State MyState, Cache, Embed IO] r => + FrameFiltered TcpConnection Packet + -> Frame Packet + -> [(TcpConnection, Int)] + -- ^ (connection, score) +mapTcpConnection aframe frame = let + streamsToCompare = getTcpStreams frame + consToCompare = map (buildTcpConnectionFromStreamId frame) (getTcpStreams frame) + scores = map (evalScore (ffCon aframe)) (rights consToCompare) + sortedScores = sortOn (Data.Ord.Down . snd) scores + evalScore con1 (FrameTcp con2 _) = (con2, similarityScore con1 con2) + in + sortedScores + +-- | +-- map_mptcp_connection_from_known_streams +mapMptcpConnection :: + FrameFiltered MptcpConnection Packet + -> Frame Packet + -> [(MptcpConnection, Int)] + -- ^ (connection, score) +mapMptcpConnection aframe frame = let + streamsToCompare = getMptcpStreams frame + consToCompare = map (buildMptcpConnectionFromStreamId frame) (getMptcpStreams frame) + scores = map (evalScore (ffCon aframe)) (rights consToCompare) + sortedScores = sortOn (Data.Ord.Down . snd) scores + -- sortedScores = reverse $ sortOn snd scores + evalScore con1 (FrameTcp con2 _) = (con2, similarityScore con1 con2) + in + sortedScores diff --git a/src/MptcpAnalyzer/Merge.hs b/src/MptcpAnalyzer/Merge.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Merge.hs @@ -0,0 +1,505 @@ +{-| +Module : MptcpAnalyzer.Merge +Description : Merges 2 dataframes into a single one with the format sender -> receiver +Maintainer : matt +License : GPL-3 + +To compute some statistics, it is necessary +to be able to map packets captured on the server to the ones mapped on the client. + +For instance if clocks on both hosts are synchronized and we know the mapping, we can compute the One-Way-Delay (OWD). +It is usually assumed to be half the roundtrip, also because there is almost no tooling to measure it. + +Another example where it is useful is when dealing with retransmissions, you may want +to identify what transmission arrived first in order to classify between successful +and penalizing retransmissons. +A similar analysis applies to MPTCP streams as reinjections can happen cross-subflows. +If we can distinguish the first successful transmission from the redundant ones, +it becomes possible to compute the real contribution ("goodput") of a subflow to +the overall MPTCP transmission. +We can thus compare different retransmissions schemes, a crucial area of research +in the MPTCP community. + +You can easily generate retransmissions using the "redundant scheduler". + +-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -O0 #-} +module MptcpAnalyzer.Merge ( + mergeTcpConnectionsFromKnownStreams + , mergeMptcpConnectionsFromKnownStreams + , convertToSenderReceiver + + -- * Types + , SenderReceiverCols + , TcpSenderReceiverCols + , MptcpSenderReceiverCols + , MergedFrame +) +where + +import MptcpAnalyzer.ArtificialFields +import MptcpAnalyzer.Types +import Prelude hiding (log) +import Tshark.TH +-- for retypeColumn +-- import MptcpAnalyzer.Frames.Utils +import MptcpAnalyzer.Map +import MptcpAnalyzer.Pcap +import MptcpAnalyzer.Utils.Text +-- (addTcpDestToFrame, StreamConnection) +import Net.IP (IP) +import Net.Tcp + + +import Control.Lens +import Data.Either (fromRight) +import Data.Foldable (toList) +import Data.Hashable +import Data.List (intercalate, intersperse, sortBy, sortOn) +import Data.Maybe (catMaybes) +import Data.Vinyl +import qualified Data.Vinyl as V +import Data.Vinyl.TypeLevel as V +import Data.Word (Word16, Word32, Word64, Word8) +import Frames as F +import Frames.CSV +import Frames.Joins +import Frames.Melt (ElemOf, RDeleteAll) +import GHC.TypeLits (KnownSymbol, Symbol) +import Language.Haskell.TH (Name) +import Net.Mptcp + +import qualified Control.Foldl as L +import qualified Data.Foldable as F +import qualified Pipes +import qualified Pipes.Prelude as Pipes +import Polysemy +import qualified Polysemy.Embed as P +import Polysemy.Log (Log) +import qualified Polysemy.Log as Log + +-- convert_to_sender_receiver +-- merge_tcp_dataframes_known_streams( +-- map_tcp_packets_via_hash +-- map_mptcp_connection_from_known_streams( +-- classify reinjections + +-- PacketMerged should be TCP/MPTCP + + +-- TODO use inner join / outer join hash +-- mapMptcpConnectionsFromKnownStreams :: FrameFiltered Packet -> FrameFiltered Packet -> FrameFiltered PacketMerged +-- mapMptcpConnectionsFromKnownStreams = + +type Score = Int + + +-- def map_mptcp_connection_from_known_streams( +-- main: MpTcpConnection, +-- other: MpTcpConnection +-- ) -> MpTcpMapping: +-- """ +-- Attempts to map subflows only if score is high enough +-- """ +-- def _map_subflows(main: MpTcpConnection, mapped: MpTcpConnection): +-- """ +-- """ +-- mapped_subflows = [] +-- for sf in main.subflows(): + +-- # generates a list (subflow, score) +-- scores = list(map(lambda x: TcpMapping(x, sf.score(x)), mapped.subflows())) +-- scores.sort(key=lambda x: x.score, reverse=True) +-- log.log(mp.TRACE, "sorted scores when mapping %s:\n %r" % (sf, scores)) +-- mapped_subflows.append((sf, scores[0])) +-- return mapped_subflows + +-- mptcpscore = main.score(other) +-- mapped_subflows = None +-- if mptcpscore > float('-inf'): +-- # (other, score) +-- mapped_subflows = _map_subflows(main, other) + +-- mapping = MpTcpMapping(mapped=other, score=mptcpscore, subflow_mappings=mapped_subflows) +-- log.log(mp.TRACE, "mptcp mapping %s", mapping) +-- return mapping + + + +-- prefix +-- type PacketMerged = +toHashablePacket :: Record HostCols -> Record HashablePart +toHashablePacket = rcast + +-- instance Hashable (Rec ElField a) where + +-- -- TODO should generate a column and add it back to HostCols +-- -- type FieldRec = Rec ElField +-- addHash :: FrameFiltered Packet -> Frame (Record (PacketHash ': HashablePart)) +-- addHash aframe = +-- fmap (addHash') ( frame) +-- where +-- frame = fmap toHashablePacket (ffFrame aframe) +-- addHash' row = Col (hashWithSalt 0 row) :& row + +-- generate a column and add it back to HostCols +addHash :: StreamConnection a b => FrameFiltered a Packet -> Frame (Record '[PacketHash] ) +addHash aframe = + -- addHashToFrame (ffFrame aframe) + fmap addHash' frame + where + frame = fmap toHashablePacket (ffFrame aframe) + addHash' row = Col (hash row) :& RNil + +addHashToFrame :: Frame Packet -> Frame (Record '[PacketHash] ) +addHashToFrame frame = + fmap (addHash') (frame') + where + frame' = fmap toHashablePacket frame + addHash' row = Col (hash row) :& RNil + + +-- '[TcpDest] V.++ +type MergedHostCols = PacketHash ': '[SenderDest] V.++ HostCols V.++ HostColsPrefixed +type MergedHostColsMptcp = PacketHash ': '[SenderDest] V.++ HostCols V.++ HostColsPrefixed + +-- not a frame but hope it should be +-- type MergedPcap a = [Rec (Maybe :. ElField) a] +type MergedPcap = [Rec (Maybe :. ElField) MergedHostCols] + +type MergedFrame = FrameRec MergedHostCols +-- type MergedFrameTcp = FrameRec (TcpDest ': MergedHostCols) +-- type MergedFrameMptcp = FrameRec (MptcpDest ': MergedHostCols) + +-- liste de +mergedPcapToFrame :: MergedPcap -> (FrameRec MergedHostCols, MergedPcap) +mergedPcapToFrame mergedRes = let + -- P.embed $ putStrLn $ "There are " ++ show (length justRecs) ++ " valid merged rows (out of " ++ show (length mergedRes) ++ " merged rows)" + -- P.embed $ putStrLn $ (concat . showFields) (head justRecs) + mbRecs = map recMaybe mergedRes + justRecs = catMaybes mbRecs + in + (toFrame justRecs, []) + + +writeMergedPcap :: FilePath -> MergedPcap -> IO () +writeMergedPcap outPath mergedPcap = do + -- showReinjects frame = + -- unlines (intercalate sep (columnHeaders (Proxy :: Proxy (Record rs))) : rows) + writeFile outPath content + where + content = intercalate "," rows + rows = Pipes.toList (F.mapM_ (Pipes.yield . show ) mergedPcap) + + +showMergedRes :: MergedPcap -> String +showMergedRes mergedPcap = do + -- showReinjects frame = + -- unlines (intercalate sep (columnHeaders (Proxy :: Proxy (Record rs))) : rows) + -- writeFile outPath content + content + where + content = intercalate "\n" rows + rows = Pipes.toList (F.mapM_ (Pipes.yield . show ) mergedPcap) + +-- +-- | Drop a column from a record. Just a specialization of rcast. +dropColumn :: forall x rs. (F.RDelete x rs F.⊆ rs) => F.Record rs -> F.Record (F.RDelete x rs) +dropColumn = F.rcast + + +-- | Merge of 2 frames +-- TODO add MptcpDest +mergeMptcpConnectionsFromKnownStreams :: + (Members '[Log, P.Embed IO] r) + => FrameFiltered MptcpConnection Packet + -> FrameFiltered MptcpConnection Packet + -> Sem r MergedFrame + -- ^ merged frame +mergeMptcpConnectionsFromKnownStreams (FrameTcp con1 frame1) (FrameTcp con2 frame2) = do + let mappedSubflows = mapSubflows con1 con2 + Log.info $ "Merging MPTCP frame1 " <> tshow (frameLength frame1) <> " and frame2 " <> tshow (frameLength frame2) + Log.info $ "Mapped subflows:\n" <> showMptcpSubflowMapping mappedSubflows + -- mergedFrames = map + mergedFrames <- mapM mergeSubflow mappedSubflows + -- Log.info $ tshow (length mergedPackets) <> " merged lists" + let res = mconcat mergedFrames + Log.info $ tshow (frameLength res) <> " concatenated merged packets" + return res + where + -- convertDest :: Record (MptcpDest ': TcpDest ': HostCols) -> Record (SenderDest ': HostCols) + -- convertDest = withNames . stripNames + convertDest :: Record '[MptcpDest] -> Record '[SenderDest] + convertDest = withNames . stripNames + + -- frameWithDests = addMptcpDest frame1 con1 + + -- frameWithSenderDest :: FrameRec (MptcpDest ': TcpDest ': HostCols) -> FrameRec (SenderDest ': HostCols) + -- frameWithSenderDest = fmap convertDest frameWithDests + + -- mergeSubflow :: (MptcpSubflow, [(MptcpSubflow, Int)]) -> MergedPcap + mergeSubflow (sf1, scores) = do + Log.debug $ "Merging pcap1 " <> tshow streamId1 <> " (" <> tshow (frameLength $ ffFrame aframe1) + <> " packets) and " <> tshow streamId2 <> " (" <> tshow (frameLength $ ffFrame aframe2) <> " packets)" + + -- TODO add MptcpDest and recast to senderDest + -- addMptcpDestToSubflowFrame + mergedSf <- mergeTcpSubflowFromKnownStreams + (FrameTcp (ffCon aframe1) (zipFrames aframe1Dest (ffFrame aframe1))) + aframe2 + -- TODO print justRecs / + -- let + -- mbRecs = map recMaybe mergedSf + -- justRecs = catMaybes mbRecs + -- -- Log.debug $ "Merging pcap1 stream" <> tshow streamId1 <> " (" <> tshow (frameLength frame1) + -- -- <> " packets) and " <> tshow streamId2 <> " (" <> tshow (frameLength frame2) <> " packets)" + -- Log.debug $ "There are " <> tshow (length justRecs) <> " valid rows (out of " + -- <> tshow (length mergedSf) <> " merged rows)" + -- Log.debug $ (concat . showFields) (head justRecs) + + return mergedSf + where + streamId1 = conTcpStreamId $ sfConn sf1 + -- here we assume it's ordered but it might not be the case + streamId2 = conTcpStreamId $ sfConn $ fst (head scores) + + aframe1 = fromRight undefined (buildFrameFromStreamId frame1 streamId1) + aframe2 = fromRight undefined (buildFrameFromStreamId frame2 streamId2) + + aframe1Dest = fmap convertDest (addMptcpDestToFrame con1 aframe1) + +-- mergeMptcpConnectionsFromKnownStreams' :: +-- FrameFiltered MptcpConnection Packet +-- -> FrameFiltered MptcpConnection Packet +-- -> MergedPcap +-- mergeMptcpConnectionsFromKnownStreams' (FrameTcp con1 frame1) (FrameTcp con2 frame2) = let +-- -- first we need to map subflow to oneanother +-- -- map mpconSubflows +-- mappedSubflows = mapSubflows con1 con2 +-- mergedFrames = map mergeSubflow mappedSubflows + +-- -- aframeSf1 = buildFrameFromStreamId frame1 (conTcpStreamId $ sfConn con1) +-- -- aframeSf1 = buildFrameFromStreamId frame2 (conTcpStreamId $ sfConn con1) +-- -- sf1 = buildTcpConnectionFromStreamId ( + +-- -- :: MptcpSubflow -> +-- mergeSubflow :: (MptcpSubflow, [(MptcpSubflow, Int)]) -> MergedPcap +-- mergeSubflow (sf1, scores) = mergeTcpConnectionsFromKnownStreams' aframe1 aframe2 +-- where +-- aframe1 = fromRight undefined (buildFrameFromStreamId frame1 (conTcpStreamId $ sfConn sf1) ) +-- aframe2 = fromRight undefined (buildFrameFromStreamId frame2 (conTcpStreamId $ sfConn $ fst (head scores ) )) +-- -- (FrameFiltered (sfConn sf) frame1) +-- -- (FrameFiltered (sfConn sf) frame2) +-- in +-- mconcat mergedFrames + + +validateMergedRes :: + (Members '[Log, P.Embed IO] r) + => MergedPcap + -> Sem r Bool +validateMergedRes l = do + Log.debug "validating mergedRes" + -- rows = Pipes.toList (F.mapM_ (Pipes.yield . show ) mergedPcap) + -- return $ L.nub (view packetId <$> l) /= length l + return True + +-- mergeTcpSubflow :: + + +mergeTcpSubflowFromKnownStreams :: + (Members '[Log, P.Embed IO] r) + => FrameFiltered MptcpSubflow PacketWithSenderDest + -> FrameFiltered MptcpSubflow Packet + -> Sem r MergedFrame +mergeTcpSubflowFromKnownStreams (FrameTcp sfcon1 frame1) (FrameTcp sfcon2 frame2) = + mergeTcpConnectionsFromKnownStreams (FrameTcp (sfConn sfcon1) frame1) + (FrameTcp (sfConn sfcon2) frame2) + +-- | Merge 2 pcaps +mergeTcpConnectionsFromKnownStreams :: + (Members '[Log, P.Embed IO] r) + => FrameFiltered TcpConnection PacketWithSenderDest + -> FrameFiltered TcpConnection Packet + -> Sem r MergedFrame +-- these are from host1 / host2 +mergeTcpConnectionsFromKnownStreams aframe1 aframe2 = do + Log.debug $ "Merging stream " <> showConnectionText (ffCon aframe1) <> " with stream " + -- Ziggy Marley + embed $ writeDSV defaultParserOptions out1 hframe1 + embed $ writeDSV defaultParserOptions out2 hframe2 + + return $ (fst . mergedPcapToFrame) mergedRes + where + -- frame1withDest = addTcpDestToFrame (ffFrame aframe1) (ffCon aframe1) + frame1withDest = ffFrame aframe1 + + out1 = "merge-tcp-1-stream-" ++ show ((conTcpStreamId . ffCon) aframe1) ++ ".tsv" + out2 = "merge-tcp-2-stream-" ++ show (conTcpStreamId $ ffCon aframe2) ++ ".tsv" + + -- we want an outerJoin , maybe with a status column like in panda + -- outerJoin returns a list of [Rec (Maybe :. ElField) ors] + mergedRes = leftJoin @'[PacketHash] (hframe1dest) processedFrame2 + + + -- (rcast @HostCols ) + -- hframe1 = zipFrames (addHash $ fmap (rcast @Packet) (ffFrame aframe1)) (ffFrame aframe1) + hframe1 = zipFrames (addHashToFrame $ fmap (rcast @HostCols) (ffFrame aframe1)) (ffFrame aframe1) + hframe1dest = hframe1 + -- hframe1dest = addTcpDestinationsToAFrame hframe1 + hframe2 :: Frame (Record ('[PacketHash] ++ HostColsPrefixed)) + hframe2 = zipFrames (addHash aframe2) host2_frame + + host2_frame = convertToHost2Cols (ffFrame aframe2) + processedFrame2 = hframe2 + + +-- | Merge of 2 frames +-- inspired by merge_tcp_dataframes_known_streams +-- mergeTcpConnectionsFromKnownStreams' :: +-- FrameFiltered TcpConnection Packet +-- -> FrameFiltered TcpConnection Packet +-- -> MergedPcap +-- -- these are from host1 / host2 +-- mergeTcpConnectionsFromKnownStreams' aframe1 aframe2 = +-- mergedFrame +-- where +-- -- (Record HostColsPrefixed) +-- -- we want an outerJoin , maybe with a status column like in panda +-- -- outerJoin returns a list of [Rec (Maybe :. ElField) ors] +-- mergedFrame = outerJoin @'[PacketHash] (hframe1dest) processedFrame2 + +-- frame1withDest = addTcpDestToFrame (ffFrame aframe1) (ffCon aframe1) + +-- hframe1 = zipFrames (addHash aframe1) frame1withDest +-- hframe1dest = hframe1 +-- -- hframe1dest = addTcpDestinationsToAFrame hframe1 +-- hframe2 :: Frame (Record ('[PacketHash] ++ HostColsPrefixed)) +-- hframe2 = zipFrames (addHash aframe2) host2_frame + +-- host2_frame = convertToHost2Cols (ffFrame aframe2) +-- processedFrame2 = hframe2 + +-- | Result of the merge of 2 pcaps +-- genExplicitRecord "" "HostCols" mergedFields + +-- gen https://hackage.haskell.org/package/vinyl-0.13.1/docs/Data-Vinyl-Derived.html +convertToHost2Cols :: FrameRec HostCols -> FrameRec HostColsPrefixed +convertToHost2Cols = fmap convertCols' + where + convertCols' :: Record HostCols -> Record HostColsPrefixed + convertCols' = withNames . stripNames + -- if you need a review on a specific patch, let us know + -- stripNames r + -- convertCols' r = F.rcast @HostColsPrefixed (retypeColumns @'[ '("fakePacketId", "fake_fakePacketId", Word64), '("fakeInterfaceName", "fake_fakeInterfaceName", Text) ] r) + +-- convertCols :: Record a -> Record b +-- convertCols = withNames . stripNames + +-- TODO and then we should compute a owd +-- , RcvAbsTime +-- type SenderReceiverCols = '[SndPacketId, RcvPacketId, SndAbsTime, RcvAbsTime, TcpDest] +-- TODO il nous faut le hash + la dest +-- | SenderHost +type TcpSenderReceiverCols = SenderHost ': TcpDest ': SenderCols V.++ ReceiverCols +type SenderReceiverCols = SenderHost ': SenderDest ': SenderCols V.++ ReceiverCols +type MptcpSenderReceiverCols = SenderHost ': MptcpDest ': SenderCols V.++ ReceiverCols + + + +-- FrameMergedOriented +-- inspirted by convert_to_sender_receiver +-- TODO this should be for a TCP frame +-- +-- In the mergedpcap we have mapped packets from 2 hosts. We then have to decide +-- between the 2 hosts which one acted as a client and which one as the server. +-- +-- @param j +-- Convert dataframe from X_HOST1 ': X_HOST2 to X_SENDER ': X_RECEIVER +-- Each mapping PACKET_HOST_1 <-> PACKET_HOST_2 is associated with its destination Server/Client +-- We thus need to find out which host acted as a Client or Server; +-- then we can select packets whose destination is the Server +-- and for those packets set the Sender to HOST1 or HOST2 +-- +-- 1/ we compare the abstime of the first packet (TODO we could select the role instead ?!) +convertToSenderReceiver :: + MergedFrame + -> FrameRec SenderReceiverCols +convertToSenderReceiver oframe = do + -- compare first packet time + if delta > 0 then + -- host1 is the client + -- then rename into sndTime, rcvTime + -- TODO + -- convertHost1AsClient + setHost1AsSenderForDest RoleServer <> setHost2AsSenderForDest RoleClient + else + -- TODO zarb because it's the same as before + setHost1AsSenderForDest RoleServer <> setHost2AsSenderForDest RoleClient + + where + -- tframe :: [Maybe (Record MergedHostCols)] + -- tframe = fmap recMaybe oframe + + -- jframe :: FrameRec MergedHostCols + -- jframe = toFrame $ catMaybes $ toList tframe + jframe = oframe + + firstRow = frameRow jframe 0 + + -- instead of taking firstRow we should compare the minima in case there are retransmissions + delta :: Double + delta = (firstRow ^. testAbsTime) - (firstRow ^. absTime) + + selectDest :: ConnectionRole -> FrameRec MergedHostCols + selectDest dest = filterFrame (\x -> x ^. senderDest == dest) jframe + + -- em fait le retype va ajouter la colonne a la fin seulement + -- zipFrames + setHost1AsSenderForDest, setHost2AsSenderForDest :: ConnectionRole -> FrameRec SenderReceiverCols + setHost1AsSenderForDest dest = fmap (\x -> Col False :& convertToSender x ) (selectDest dest) + + -- (if h1role == RoleClient then RoleServer else RoleClient)) + setHost2AsSenderForDest dest = fmap (\x -> Col True :& convertToReceiver x ) (selectDest dest) + + -- convertToSender, convertToReceiver :: Record MergedHostCols -> Record SenderReceiverCols + convertToSender r = let + -- TODO add tcpDest + senderCols :: Record SenderCols + senderCols = (withNames . stripNames . F.rcast @HostCols) r + receiverCols :: Record ReceiverCols + receiverCols = (withNames . stripNames . F.rcast @HostColsPrefixed) r + in + rget @SenderDest r :& rappend senderCols receiverCols + + convertToReceiver r = let + senderCols :: Record SenderCols + senderCols = (withNames . stripNames . F.rcast @HostColsPrefixed) r + receiverCols :: Record ReceiverCols + receiverCols = (withNames . stripNames . F.rcast @HostCols) r + in + rget @SenderDest r :& rappend senderCols receiverCols + -- convert ("first host") to sender/receiver + -- TODO this could be improved + + +-- | Add a One-Way-Delay column to the results +-- addOWD :: Frame (Record RecSenderReceiver) -> Frame (Record '[OWD] ++ RecSenderReceiver) +-- addOWD = fmap addOWD' +-- where +-- addOWD' = (rcvAbsTime x - sndAbsTime x) diff --git a/src/MptcpAnalyzer/Pcap.hs b/src/MptcpAnalyzer/Pcap.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Pcap.hs @@ -0,0 +1,659 @@ +{-| +Module: MptcpAnalyzer.Pcap +Maintainer : matt +License : GPL-3 + +Pot-pourri +-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE PackageImports #-} +module MptcpAnalyzer.Pcap ( + addTcpDestToFrame + , addMptcpDestToFrame + , addMptcpDest + , addTcpDestinationsToAFrame + , buildTcpConnectionFromStreamId + , buildMptcpConnectionFromStreamId + , defaultParserOptions + , genTcpDestFrame + , genTcpDestFrameFromAFrame + , exportToCsv + , loadRows + , getTcpStreams + , getMptcpStreams + , buildSubflowFromRecord + , buildSubflowFromTcpStreamId + , buildTcpConnectionFromRecord + , buildTcpConnectionTupleFromRecord + + , genMptcpEndpointConfigFromRow + -- TODO remove ? use instance instead + , showMptcpSubflowText + , StreamConnection(..) + , showConnection + , scoreTcpCon + , scoreMptcpCon + -- , showMptcpSubflowText + ) +where + + +import MptcpAnalyzer.ArtificialFields +import MptcpAnalyzer.Stream +import MptcpAnalyzer.Types +import MptcpAnalyzer.Utils.Text +import Net.Mptcp.Connection +import Net.Tcp +import Net.Stream +import Net.Tcp.Constants (TcpFlag(..)) +import Tshark.Fields +import Tshark.TH + +-- hackage +import Control.Lens ((^.)) +import Data.Kind (Type) +import Data.Monoid (First(..)) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Vector as V +import Frames +import Frames.CSV + ( ParserOptions(..) + , QuotingMode(..) + , ReadRec + , pipeTableEitherOpt + , produceTextLines + , readFileLatin1Ln + , readTableMaybeOpt + ) +import Frames.Col +import Frames.ColumnTypeable (Parseable(..), Parsed(..), parseIntish) +import Frames.ShowCSV +import Frames.TH +import System.Exit +import System.IO + ( BufferMode(LineBuffering) + , Handle + , SeekMode(AbsoluteSeek) + , hGetContents + , hSeek + , hSetBuffering + ) +import System.Process +-- for Record +-- import Frames.Rec (Record(..)) +import Data.List (intercalate) +import Net.IP +-- for symbol +-- import GHC.Types +import qualified Control.Foldl as L +import qualified Data.Set as Set +-- import Language.Haskell.TH +-- import Language.Haskell.TH.Syntax +-- import Lens.Micro +-- import Lens.Micro.Extras +import Control.Lens +import qualified Data.Foldable as F +import Data.Maybe (catMaybes, fromJust, isNothing) +import Data.Vinyl (ElField(..), Rec(..), rapply, rmapX, xrec) +import Data.Vinyl.Class.Method +import Data.Vinyl.Functor (Compose(..), (:.)) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Base (Symbol) +import GHC.List (foldl') +import GHC.TypeLits (KnownSymbol) +import Numeric (readHex) +import Pipes (Producer, cat, (>->)) +import qualified Pipes.Prelude as P +-- import qualified Frames.InCore +import Control.Exception (assert) +import Data.Either (lefts, rights) +import qualified Data.Map as Map +import Debug.Trace +import qualified Frames.InCore as I +import GHC.IO.Handle (hClose) +import System.Environment (getEnvironment) +import System.IO.Temp +import Tshark.Main + +-- tableTypes is a Template Haskell function, which means that it is executed at compile time. It generates a data type for our CSV, so we have everything under control with our types. + + +-- on veut la generer +-- [[t|Ident Int|], [t|Happiness|]] +-- tableTypesExplicit' :: [Q Type] -> RowGen a -> FilePath -> DecsQ +-- tableTypesExplicit' + +-- tableTypesExplicit' +-- (getTypes baseFields) +-- -- [ Field Word64 ] +-- -- [[t| Word64|]] +-- ((rowGen "data/test-1col.csv") +-- { rowTypeName = "Packet" +-- , separator = "," +-- -- TODO I could generate it as well +-- -- , columnNames +-- }) +-- -- path +-- "data/test-simple.csv" + + + +-- shadow type to know if it was filtered or not +-- Make it a record ? +-- first argument allows to override csv header ("headerOverride") +defaultParserOptions :: ParserOptions +defaultParserOptions = ParserOptions Nothing (T.pack [csvDelimiter defaultTsharkPrefs]) NoQuoting + +-- nub => remove duplicates +-- or just get the column +getTcpStreams :: FrameRec HostCols -> [StreamIdTcp] +getTcpStreams ps = L.fold L.nub (view tcpStream <$> ps) + +-- | to list +getMptcpStreams :: FrameRec HostCols -> [StreamId Mptcp] +getMptcpStreams ps = L.fold L.nub $ catMaybes $ F.toList (view mptcpStream <$> ps) +-- filterFrame (\x -> x ^. mptcpStream == Just streamId) frame + + + +{- Export to CSV +sets WIRESHARK_CONFIG_DIR so that the user profile doesn't influence the output +-} +exportToCsv :: + TsharkParams + -> FilePath -- ^Path to the pcap + -> Handle -- ^ temporary file +-- ^See haskell:readCreateProcessWithExitCode + -> IO (ExitCode, String) +exportToCsv params pcapPath tmpFileHandle = do + curEnv <- getEnvironment + withSystemTempFile "tshark-profile" $ \tempDir _ -> do + let + (RawCommand bin args) = generateCsvCommand fields (Right pcapPath) (params ) + createProc :: CreateProcess + createProc = (proc bin args) { + std_err = CreatePipe, + std_out = UseHandle tmpFileHandle, + env = Just $ curEnv ++ [ ("WIRESHARK_CONFIG_DIR", tempDir) ], + delegate_ctlc = True + } + putStrLn $ "Exporting fields " ++ show fields + putStrLn $ "Command run: " ++ show (RawCommand bin args) + -- TODO redirect stdout towards the out handle + hSetBuffering tmpFileHandle LineBuffering + hSeek tmpFileHandle AbsoluteSeek 0 >> T.hPutStrLn tmpFileHandle fieldHeader + (_, _, Just herr, ph) <- createProcess_ "error" createProc + exitCode <- waitForProcess ph + -- TODO do it only in case of error ? + err <- hGetContents herr + hClose herr + return (exitCode, err) + where + fields :: [T.Text] + fields = Map.elems $ Map.map tfieldFullname baseFields + + csvSeparator = T.pack [csvDelimiter params] + fieldHeader :: Text + fieldHeader = T.intercalate csvSeparator (Map.keys baseFields) + + +loadRows :: (I.RecVec a, ReadRec a) => FilePath -> IO (FrameRec a) +loadRows path = inCoreAoS ( + eitherProcessed path + ) + + +type ManEither = Rec (Either T.Text :. ElField) (RecordColumns Packet) + +-- pipteTable will tokenize on its own +-- loadRowsEither :: MonadSafe m => FilePath -> Producer ManEither m () +-- loadRowsEither path = produceTextLines path >-> pipeTableEitherOpt defaultParserOptions + +{- |Load rows and errors when it can't load a specific line +-} +eitherProcessed :: (ReadRec a, MonadSafe m) => FilePath -> Producer (Record a) m () +eitherProcessed path = produceTextLines path + >-> pipeTableEitherOpt defaultParserOptions >-> P.map fromEither + where + -- fromEither :: Rec (Either Text :. ElField) (RecordColumns Packet) -> Packet + fromEither x = case recEither x of + Left _txt -> error ( "eitherProcessed failure : " ++ T.unpack _txt) + Right pkt -> pkt + + recEither = rtraverse getCompose + +-- | Undistribute 'Maybe' from a 'Rec' 'Maybe'. This is just a +-- specific usage of 'rtraverse', but it is quite common. +-- recEither :: Rec (Either Text :. ElField) cs -> Either Text (Record cs) +-- recEither = rtraverse getCompose + +-- data TsharkPrefs = TsharkPrefs { +-- analyzeTcpSeq :: Bool +-- , analyzeMptcp :: Bool +-- , mptcpRelSeq :: Bool +-- , analyzeMptcp :: Bool +-- } deriving Show + +{- +-} +getTcpFrame :: FrameRec HostCols -> StreamId Tcp -> Either String (FrameFiltered TcpConnection Packet) +getTcpFrame = buildTcpConnectionFromStreamId + +-- | For now assume the packet is the first syn from client to server +-- TODO this is wrong, assumes source ip is client, convert to return a TcpConnectionOriented +buildTcpConnectionFromRecord :: ( + IpFields rs, TcpSrcPort ∈ rs, TcpDestPort ∈ rs, TcpStream ∈ rs + ) => Record rs -> TcpConnection +buildTcpConnectionFromRecord r = + TcpConnection { + conTcpClientIp = r ^. ipSource + , conTcpServerIp = r ^. ipDest + , conTcpClientPort = r ^. tcpSrcPort + , conTcpServerPort = r ^. tcpDestPort + , conTcpStreamId = r ^. tcpStream + } + +buildTcpConnectionTupleFromRecord :: ( + IpFields rs, TcpSrcPort ∈ rs, TcpDestPort ∈ rs, TcpStream ∈ rs + ) => Record rs -> TcpConnectionOriented +buildTcpConnectionTupleFromRecord r = + TcpConnectionOriented { + conTcpSourceIp = r ^. ipSource + , conTcpDestinationIp = r ^. ipDest + , conTcpSourcePort = r ^. tcpSrcPort + , conTcpDestinationPort = r ^. tcpDestPort + -- , conTcpStreamId = r ^. tcpStream + } + +{- Builds a Tcp connection from a non filtered frame +-} +buildTcpConnectionFromStreamId :: + FrameRec HostCols + -> StreamId Tcp -> Either String (FrameFiltered TcpConnection Packet) +buildTcpConnectionFromStreamId frame streamId = + if frameLength synPackets < 1 then + Left $ "No packet with any SYN flag for tcp.stream " ++ show streamId + else + -- TODO check who is client + Right $ FrameTcp (buildTcpConnectionFromRecord $ frameRow synPackets 0) streamPackets + where + streamPackets = filterFrame (\x -> x ^. tcpStream == streamId) frame + synPackets = filterFrame (\x -> TcpFlagSyn `elem` (x ^. tcpFlags)) streamPackets + + +-- | +-- buildMasterSubflowFromRecord :: + + +-- | Builds +-- should expect a filteredFrame with MPTCP +-- buildSubflowFromTcpStreamId :: FrameFiltered TcpConnection Packet -> StreamId Tcp -> Either String (FrameFiltered MptcpSubflow Packet) +buildSubflowFromRecord :: Packet -> MptcpSubflow +buildSubflowFromRecord row = + MptcpSubflow { + sfConn = sfCon + -- TODO ignore if it's master token + , sfJoinToken = row ^. mptcpRecvToken + , sfPriority = Nothing + -- TODO + , sfLocalId = 0 + , sfRemoteId = 0 + -- todo load it from row + , sfInterface = Nothing + } + where + sfCon = buildTcpConnectionFromRecord row + + +buildSubflowFromTcpStreamId :: + ( + rs ⊆ HostCols + , I.RecVec rs + , TcpFlags ∈ rs , TcpStream ∈ rs, MptcpRecvToken ∈ rs + , IpSource ∈ rs, IpDest ∈ rs, TcpSrcPort ∈ rs, TcpDestPort ∈ rs, TcpStream ∈ rs + ) + => FrameRec rs + -> StreamId Tcp + -> Either String (FrameFiltered MptcpSubflow (Record rs)) +buildSubflowFromTcpStreamId frame streamId = + if frameLength synPackets < 1 then + Left $ "No packet with any SYN flag for tcp.stream " ++ show streamId + else + -- TODO check who is client + Right $ FrameTcp sf streamPackets + where + syn0 = frameRow synPackets 0 + streamPackets = filterFrame (\x -> x ^. tcpStream == streamId) frame + synPackets = filterFrame (\x -> TcpFlagSyn `elem` (x ^. tcpFlags)) streamPackets + sfCon = buildTcpConnectionFromRecord syn0 + -- rcvToken + sf = MptcpSubflow { + sfConn = sfCon + -- TODO ignore if it's master token + , sfJoinToken = syn0 ^. mptcpRecvToken + , sfPriority = Nothing + , sfLocalId = 0 + , sfRemoteId = 0 + , sfInterface = Nothing + } + +-- | Sets mptcp role column +-- TODO maybe je devrais juste generer un +addMptcpDest :: + ( + -- Frames.InCore.RecVec rs, + -- HostCols ⊆ rs + -- MptcpStream ∈ rs, TcpStream ∈ rs, IpSource ∈ rs, IpDest ∈ rs, TcpSrcPort ∈ rs, TcpDestPort ∈ rs + -- rs = HostCols + ) => + Frame (Record HostCols) + -> MptcpConnection + -> FrameRec ( + MptcpDest ': TcpDest ': HostCols + ) +addMptcpDest frame con = + -- foldl' (\tframe sf -> addDestToFrame tframe sf) startingFrame subflows + mconcat subflowFrames + where + -- filteredFrame = filterFrame (\x -> x ^. mptcpStream == Just (mpconStreamId con)) frame + -- filteredFrame = filterFrame (\x -> (rgetField @MptcpStream x) == Just (mpconStreamId con)) frame + + subflowFrames = map addDestsToSubflowFrames subflows + + addDestsToSubflowFrames sf = addMptcpDestToFrame' (addTcpDestToFrame frame (sfConn sf)) sf + + addMptcpDest' role x = Col role :& x + + addMptcpDestToFrame' frame' sf = fmap (addMptcpDest' (getMptcpDest con sf)) frame' + + startingFrame = fmap setTempDests frame + setTempDests :: Record rs -> Record ( MptcpDest ': TcpDest ': rs) + setTempDests x = Col RoleClient :& Col RoleClient :& x + addMptcpDestToRec x role = Col role :& x + subflows = Set.toList $ _mpconSubflows con + +addMptcpDestToFrame :: MptcpConnection -> FrameFiltered MptcpSubflow Packet -> FrameRec '[MptcpDest] +addMptcpDestToFrame mpcon (FrameTcp sf frame) = fmap (addMptcpDest' (getMptcpDest mpcon sf)) frame + where + addMptcpDest' role x = Col role :& RNil + + +getMptcpDest :: MptcpConnection -> MptcpSubflow -> ConnectionRole +getMptcpDest mptcpCon sf = case sfJoinToken sf of + -- master subflow, dest is by definition the server + Nothing -> RoleServer + Just token -> if token == (_mecToken . _mpconServerConfig) mptcpCon then + RoleServer + else + RoleClient + + +-- | Sets TCP role column +-- append a column with a value role +-- Todo accept a 'FrameFiltered' +-- I want to check it is included +-- TODO add an unsafe version ? +addTcpDestToFrame :: ( + I.RecVec rs + ,IpSource ∈ rs, IpDest ∈ rs + , IpDest ∈ rs, TcpSrcPort ∈ rs, TcpDestPort ∈ rs + , TcpStream ∈ rs + ) + => FrameRec rs + -> TcpConnection + -> FrameRec ( TcpDest ': rs ) +addTcpDestToFrame frame con = do + assert + -- check that they all belong to the same stream + (length ( L.fold L.nub (view tcpStream <$> frame)) == 1) + fmap (\x -> addTcpDestToRec x (computeTcpDest x con)) streamFrame + where + streamFrame = frame + + +-- | Generates a frame with a single column containing the TcpDest +genTcpDestFrame :: ( + I.RecVec rs + , IpSource ∈ rs, IpDest ∈ rs + , TcpSrcPort ∈ rs, TcpDestPort ∈ rs + , TcpStream ∈ rs + ) + => FrameRec rs + -> TcpConnection + -> FrameRec '[TcpDest] +genTcpDestFrame frame con = fmap (\x -> Col (computeTcpDest x con) :& RNil) streamFrame + where + streamFrame = filterFrame (\x -> rgetField @TcpStream x == conTcpStreamId con) frame + +genTcpDestFrameFromAFrame :: ( + I.RecVec rs + , IpSource ∈ rs, IpDest ∈ rs + , TcpSrcPort ∈ rs, TcpDestPort ∈ rs + , TcpStream ∈ rs + ) + => FrameFiltered TcpConnection (Record rs) + -> FrameRec '[TcpDest] +genTcpDestFrameFromAFrame aframe = genTcpDestFrame (ffFrame aframe) (ffCon aframe) + + +computeTcpDest :: ( + TcpStream ∈ rs + , IpFields rs + , TcpSrcPort ∈ rs + , TcpDestPort ∈ rs + ) => Record rs + -> TcpConnection -> ConnectionRole +computeTcpDest x con = if rgetField @IpSource x == conTcpClientIp con + && rgetField @IpDest x == conTcpServerIp con + && rgetField @TcpSrcPort x == conTcpClientPort con + && rgetField @TcpDestPort x == conTcpServerPort con + && rgetField @TcpDestPort x == conTcpServerPort con + -- TODO should error if not the same streamId + -- && (rgetField @TcpStream x) == (conTcpStreamId con) + then RoleServer else RoleClient + + +-- | TODO +-- See @addTcpDestToFrame@ +addTcpDestinationsToAFrame :: ( + -- HostCols ⊆ rs, + I.RecVec rs + -- , HostCols <: rs + -- , HostCols ∈ rs + , IpFields rs + , TcpFields rs) + => FrameFiltered TcpConnection (Record rs) + -> FrameFiltered TcpConnection (Record (TcpDest ': rs)) +addTcpDestinationsToAFrame aframe = + aframe { ffFrame = addDestinationsToFrame' (ffCon aframe)} + where + frame = ffFrame aframe + addDestinationsToFrame' con = addTcpDestToFrame frame con + +-- append a field with a value role +addTcpDestToRec :: (TcpStream ∈ rs, IpSource ∈ rs, IpDest ∈ rs, TcpSrcPort ∈ rs, TcpDestPort ∈ rs) + => Record rs -> ConnectionRole -> Record ( TcpDest ': rs ) +addTcpDestToRec x role = (Col role) :& x + + +-- TODO take into account the different mptcp versions ? +genMptcpEndpointConfigFromRow :: Packet -> Maybe MptcpEndpointConfiguration +genMptcpEndpointConfigFromRow synAckPacket = + case (synAckPacket ^. mptcpSendKey, synAckPacket ^. mptcpExpectedToken, synAckPacket ^. mptcpVersion) of + (Just key, Just token, Just version) -> Just $ MptcpEndpointConfiguration key token version + _ -> Nothing + -- error $ "Could not find key/token/version " ++ show synAckPacket + +-- retreiveMptcpServerTokenFromRow :: Packet -> Maybe (Word64, Word32) +-- retreiveMptcpServerTokenFromRow synAckPacket = +-- case (synAckPacket ^. mptcpSendKey, synAckPacket ^. mptcpExpectedToken) of +-- (Just key, Just token) -> Just (key, token) +-- _ -> error "Could not generate" + +-- TODO + +buildMptcpConnectionFromStreamId :: FrameRec HostCols + -> StreamId Mptcp -> Either String (FrameFiltered MptcpConnection Packet) +buildMptcpConnectionFromStreamId frame streamId = do + -- Right $ frameLength synPackets + if frameLength streamPackets < 1 then + Left $ "No packet with mptcp.stream == " ++ show streamId + else if frameLength synAckPackets < 1 then + Left $ "No syn/ack packet found for stream" ++ show streamId ++ " First packet: " + -- ++ show streamPackets + else if lefts subflows /= [] then + Left $ concat (lefts subflows) + else if mbServerConfig == Nothing then + Left $ "Could not find MPTCP server config in " ++ show synAckPacket + else + + case buildTcpConnectionFromStreamId streamPackets (synPacket ^. tcpStream) of + Left err -> Left err + Right aframe -> let + clientFrame = filterFrame (\x -> ((not . isNothing) (x ^. mptcpSendKey))) (ffFrame aframe) + mbClientConfig = genMptcpEndpointConfigFromRow (frameRow clientFrame 0) + in + if frameLength clientFrame == 0 then + Left $ "Could not find mptcp client key" + else + -- TODO now add a check on abstime + -- if ds.loc[server_id, "abstime"] < ds.loc[client_id, "abstime"]: + -- log.error("Clocks are not synchronized correctly") + -- update temporary fframe with the computed subflows + Right $ FrameTcp { + ffCon = tempMptcpConn mbClientConfig + , ffFrame = streamPackets + } + where + streamPackets :: FrameRec HostCols + streamPackets = filterFrame (\x -> x ^. mptcpStream == Just streamId) frame + -- + -- |Just for the time + tempMptcpConn clientConfig = MptcpConnection { + mpconStreamId = streamId + -- kinda risky, assumes we have the server key always + , _mpconServerConfig = fromJust mbServerConfig + , _mpconClientConfig = fromJust clientConfig + -- , mptcpNegotiatedVersion = fromIntegral $ fromJust clientMptcpVersion :: Word8 + + , _mpconSubflows = Set.fromList $ map ffCon (rights subflows) + } + -- suppose tcpflags is a list of flags, check if it is in the list + -- of type FrameRec [(Symbol, *)] + -- Looking for synack packets + synPackets = filterFrame (\x -> TcpFlagSyn `elem` (x ^. tcpFlags)) streamPackets + synAckPackets = filterFrame (\x -> TcpFlagSyn `elem` (x ^. tcpFlags) && TcpFlagAck `elem` (x ^. tcpFlags)) streamPackets + + + synPacket = frameRow synPackets 0 + synAckPacket = frameRow synAckPackets 0 + mbServerConfig = genMptcpEndpointConfigFromRow synAckPacket + -- clientConfig :: Maybe MptcpEndpointConfiguration + -- clientConfig = case mbServerConfig of + -- Nothing -> Nothing + -- Just serverConfig -> + -- if mecVersion == 0 then genMptcpEndpointConfigFromRow synPacket + -- else genMptcpEndpointConfigFromRow + + masterTcpstreamId = synPacket ^. tcpStream + clientMptcpVersion = synPacket ^. mptcpVersion + + -- + subflows = map (buildSubflowFromTcpStreamId frame) (getTcpStreams streamPackets) + + +-- filterFrame / buildFrameFromStreamId +{- Common interface to work with TCP and MPTCP connections +-} +class StreamConnection a b | a -> b where + -- | How + -- type ConnectionType :: Type + showConnectionText :: a -> Text + -- describeConnection :: a -> Text + buildFrameFromStreamId :: Frame Packet -> StreamId b -> Either String (FrameFiltered a Packet) + -- type Needs a :: Constraint + + -- type toto = Int + + -- | Compare two conection and give a similarityScore + similarityScore :: a -> a -> Int + -- listConnections :: FrameFiltered () [a] + -- summarize :: a -> Text + -- GetLabel ? + + +-- | Compares 2 TCP connections and gives a score +-- The higher the score, the more similar the 2 connections are. +scoreTcpCon :: TcpConnection -> TcpConnection -> Int +scoreTcpCon con1 con2 = + -- If every parameter is equal, returns +oo else 0 + -- TODO also match on isn in case ports got reused + + foldl (\acc toAdd -> acc + 10 * fromEnum toAdd) (0 :: Int) [ + conTcpClientIp con1 == conTcpClientIp con2 + , conTcpClientPort con1 == conTcpClientPort con2 + , conTcpServerIp con1 == conTcpServerIp con2 + , conTcpServerPort con1 == conTcpServerPort con2 + ] + + +instance StreamConnection TcpConnection Tcp where + showConnectionText = showTcpConnectionText + buildFrameFromStreamId = buildTcpConnectionFromStreamId + similarityScore = scoreTcpCon + + +-- | Computes a score +scoreMptcpCon :: MptcpConnection -> MptcpConnection -> Int +scoreMptcpCon con1 con2 = + let keyScore = if con1 ^. mpconServerConfig ^. mecKey == con2 ^. mpconServerConfig ^. mecKey + && con1 ^. mpconClientConfig ^. mecKey == con2 ^. mpconClientConfig ^. mecKey + then 200 + else 0 + in + keyScore + + +instance StreamConnection MptcpConnection Mptcp where + showConnectionText = showMptcpConnectionText + buildFrameFromStreamId = buildMptcpConnectionFromStreamId + similarityScore = scoreMptcpCon + +instance StreamConnection MptcpSubflow Tcp where + showConnectionText = showMptcpSubflowText + buildFrameFromStreamId = buildSubflowFromTcpStreamId + -- TODO use score as well + similarityScore sf1 sf2 = similarityScore (sfConn sf1) (sfConn sf2) + + +-- |Show the subflow (ids) +showMptcpSubflowText :: MptcpSubflow -> Text +showMptcpSubflowText sf = + showConnectionText (sfConn sf) <> " (Local/Remote ids: " <> tshow (sfLocalId sf) + <> "/" <> tshow (sfRemoteId sf) <> ", token " <> tshow (sfJoinToken sf) <> ")" + +-- TODO add sthg in case it's the master subflow ? +showConnection :: StreamConnection a b => a -> String +showConnection = T.unpack . showConnectionText diff --git a/src/MptcpAnalyzer/Plots.hs b/src/MptcpAnalyzer/Plots.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Plots.hs @@ -0,0 +1,21 @@ +module MptcpAnalyzer.Plots +( + -- module MptcpAnalyzer.Plots.Stream +) +where + +import MptcpAnalyzer.Plots.Stream +import MptcpAnalyzer.Types + + +-- connectionToLabel :: Connection -> String +-- connectionToLabel con@TcpConnection{} = +-- showIp (conTcpClientIp con) <> ":" <> tshow (conTcpClientPort con) <> " -> " +-- <> showIp (conTcpServerIp con) <> ":" <> tshow (conTcpServerPort con) +-- <> " (tcp.stream: " <> tshow (conTcpStreamId con) <> ")" +-- where +-- showIp = Net.IP.encode + +-- plotTcpSeq :: +-- plot (line ("TCP " ++ field ++ " (" ++ show dest ++ ")") [ [ (d,v) | (d,v) <- zip timeData seqData ] ]) + diff --git a/src/MptcpAnalyzer/Plots/Live.hs b/src/MptcpAnalyzer/Plots/Live.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Plots/Live.hs @@ -0,0 +1,199 @@ +{- +Module: MptcpAnalyzer.Commands.Plots.Live +Description : Description +Maintainer : matt +Portability : Linux +-} +module MptcpAnalyzer.Plots.Live +where + +import qualified Data.Map as Map +import qualified Data.Text as T +import MptcpAnalyzer.ArtificialFields +import MptcpAnalyzer.Cache +import MptcpAnalyzer.Plots.Types +import MptcpAnalyzer.Prelude +import MptcpAnalyzer.Utils.Text +import Net.Tcp +import qualified Polysemy.Embed as P +import qualified Polysemy.Log as Log +import System.Process hiding (runCommand) +import Tshark.Live +import Tshark.Main + +import Polysemy (Final, Members, Sem, runFinal) +import qualified Polysemy as P +import qualified Polysemy.Embed as P +import qualified Polysemy.IO as P +import qualified Polysemy.Internal as P +import Polysemy.Log (Log) +import qualified Polysemy.Log as Log +import Polysemy.Log.Colog (interpretLogStdout) +import qualified Polysemy.State as P +import Polysemy.Trace (trace) +import qualified Polysemy.Trace as P + +-- import MptcpAnalyzer.Commands.Definitions as CMD +import Control.Monad.State (execStateT) +import Data.Maybe (fromMaybe, fromJust) +import GHC.IO.Handle +import Pipes (runEffect) +import System.Exit +import System.IO (stdout) +import Tshark.Fields +import Tshark.Capture +import Net.Mptcp.Connection +import Control.Lens ((^.)) + +configureLivePlotTcp :: Members '[Log, P.Trace, P.Embed IO] r + => LivePlotTcpSettings + -> Sem r LiveStatsTcp +configureLivePlotTcp (LivePlotTcpSettings connectionFilter mbFake mbConnectionRole ifname) = do + let + fields = Map.elems $ Map.map tfieldFullname baseFields + + -- stats/packetCount/Frame + -- keeping it light for now + destination = fromMaybe RoleServer mbConnectionRole + lsConfig = LiveStatsConfig connectionFilter destination + + -- initialLiveStats :: LiveStatsTcp = LiveStats mempty 0 mempty + toLoad = case mbFake of + Just filename -> Right filename + Nothing -> Left ifname + + --capture-comment + tsharkPrefs = defaultTsharkPrefs { + tsharkReadFilter = Just $ genReadFilterFromTcpConnection connectionFilter (Just destination) + } + (RawCommand bin genArgs) = generateCsvCommand fields toLoad tsharkPrefs + -- args = genArgs ++ ["--capture-comment='Generated by mptcpanalyzer'"] + args = genArgs ++ [ "-l"] + createProc :: CreateProcess + createProc = (proc bin args) { + std_err = CreatePipe + -- Inherit, + , std_out = CreatePipe + -- lets the child handle Ctrl-c + , delegate_ctlc = True + } + + Log.info $ "Looking at destination " <> tshow destination + + trace $ "Command run: " ++ show (RawCommand bin args) + trace $ "Command run: " ++ showCommandForUser bin args + -- Log.info $ "Starting " <> tshow bin <> tshow args + ls <- P.embed $ startLivePlot lsConfig createProc + pure ls + +startLivePlot :: LiveStatsConfig -> CreateProcess -> IO LiveStatsTcp +startLivePlot lsConfig createProc = do + let initialLiveStats :: LiveStatsTcp = LiveStats mempty mempty 0 mempty False + + (_, Just hout, Just herr, ph) <- createProcess_ "error when creating process" createProc + -- hSetBuffering stdout NoBuffering + hSetBuffering stdout LineBuffering + + -- non blocking + exitCode <- getProcessExitCode ph + case exitCode of + Just code -> putStrLn "Finished" >> pure initialLiveStats + _ -> do + -- hSetBuffering hout LineBuffering + -- hSetBuffering herr NoBuffering + putStrLn $ "Starting live TCP plot with initial stats: (before): " ++ show (lsPackets initialLiveStats) + liveStats <- execStateT (runEffect (tsharkLoopTcp lsConfig hout)) initialLiveStats + putStrLn $ "Live stats (after): " ++ show (lsPackets liveStats) + -- putStrLn $ "Live stats (after): " ++ (T.unpack . showLiveStatsTcp) liveStats + -- blocking + putStrLn $ "Live stats (after): " ++ (T.unpack . showLiveStatsTcp) liveStats + putStrLn $ "Waiting for process" + exitCode2 <- waitForProcess ph + case exitCode2 of + ExitSuccess -> putStrLn "Success" >> pure liveStats + _ -> do + putStrLn "hGetContents" + hGetContents herr >>= putStrLn >> pure initialLiveStats + -- putStrLn $ "final exitCode" + +-- LiveStatsMptcp +startMptcpCapture :: +-- Members '[Log, P.Trace, P.Embed IO] r => + LiveStatsConfig + -> LiveStatsMptcp + -> CreateProcess + -> IO LiveStatsMptcp + +startMptcpCapture lsConfig initialLiveStats createProc = do + (_, Just hout, Just herr, ph) <- createProcess_ "error when creating process" createProc + hSetBuffering stdout LineBuffering + -- non blocking + exitCode <- getProcessExitCode ph + case exitCode of + Just code -> putStrLn "Finished" >> pure initialLiveStats + _ -> do + -- hSetBuffering hout LineBuffering + -- hSetBuffering herr NoBuffering + putStrLn $ "Starting live mptcp plotting stats (before): " + liveStats <- execStateT (runEffect (tsharkLoopMptcp lsConfig hout)) initialLiveStats + case liveStats ^. lsmMaster of + Nothing -> putStrLn "Could not detect the mptcp connection" + Just master -> putStrLn $ "Live stats (after): " ++ (T.unpack $ showMptcpConnectionText master) + -- putStrLn $ "Live stats (after): " ++ (T.unpack $ showMptcpConnectionText (fromJust $ liveStats ^. lsmMaster)) + putStrLn $ "Live stats (after): " ++ (T.unpack . showLiveStatsMptcp) liveStats + -- putStrLn $ "Live stats (after): " ++ show (lsPackets liveStats) + -- blocking + exitCode2 <- waitForProcess ph + case exitCode2 of + ExitSuccess -> putStrLn "Success" >> pure liveStats + _ -> do + putStrLn "hGetContents" + hGetContents herr >>= putStrLn >> pure liveStats + -- putStrLn $ "final exitCode" + +{- | Starts live analysis of an MPTCP flow +One needs to filter +-} +configureLivePlotMptcp :: Members '[Log, Cache, P.Trace, P.Embed IO] r => + LivePlotTcpSettings + -- -> CaptureSettingsMptcp + -> Sem r LiveStatsMptcp + +configureLivePlotMptcp (LivePlotTcpSettings connectionFilter mbFake mbConnectionRole ifname) = do + let + destination = fromMaybe RoleServer mbConnectionRole + + lpConfig = LiveStatsConfig connectionFilter destination + initialLiveStats = mkLiveStatsMptcp + fields = Map.elems $ Map.map tfieldFullname baseFields + + -- stats/packetCount/Frame + -- keeping it light for now + toLoad = case mbFake of + Just filename -> Right filename + Nothing -> Left ifname + + --capture-comment + tsharkPrefs = defaultTsharkPrefs { + tsharkReadFilter = Just $ genReadFilterMptcpFromMptcpConnection + } + (RawCommand bin genArgs) = generateCsvCommand fields toLoad tsharkPrefs + -- args = genArgs ++ ["--capture-comment='Generated by mptcpanalyzer'"] + args = genArgs ++ [ "-l"] + createProc :: CreateProcess + createProc = (proc bin args) { + std_err = CreatePipe + -- Inherit, + , std_out = CreatePipe + -- lets the child handle Ctrl-c + , delegate_ctlc = True + } + + Log.info $ "Looking at destination " <> tshow destination + + trace $ "Command run: " ++ show (RawCommand bin args) + trace $ "Command run: " ++ showCommandForUser bin args + -- Log.info $ "Starting " <> tshow bin <> tshow args + ls <- P.embed $ startMptcpCapture lpConfig initialLiveStats createProc + pure ls + diff --git a/src/MptcpAnalyzer/Plots/Stream.hs b/src/MptcpAnalyzer/Plots/Stream.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Plots/Stream.hs @@ -0,0 +1,39 @@ +-- TODO make as plugin +module MptcpAnalyzer.Plots.Stream +where + + + + +-- import Diagrams.Backend.Rasterific +-- import Diagrams (dims2D, width, height) +-- import Frames +-- import Graphics.Rendering.Chart.Backend.Diagrams (defaultEnv, runBackendR) +-- import Graphics.Rendering.Chart.Easy + +-- import Katip + +-- where expect a parser +-- class Plot +-- +-- mkPlot :: IO () +-- mkPlot = do env <- defaultEnv bitmapAlignmentFns 640 480 +-- let chart2diagram = fst . runBackendR env . toRenderable . execEC +-- xs <- runSafeT $ P.toListM fisherIncomeData +-- let d = chart2diagram $ do +-- layout_title .= "Farmer/fisher Income vs Age" +-- layout_x_axis . laxis_title .= "Age (Years)" +-- layout_y_axis . laxis_title .= "Capital Gain ($)" +-- plot (points "" (map (view age &&& view capitalGain) xs)) +-- sz = dims2D (width d) (height d) +-- renderRasterific "plot2.png" sz d + +-- Manually fused folds +-- main :: IO () +-- main = do ((age_,inc,n), _) <- runSafeT $ +-- P.fold' aux (0,0,0::Double) id fisherIncomeData +-- putStrLn $ "The average farmer/fisher is "++ +-- show (fromIntegral age_ / n) ++ +-- " and made " ++ show (fromIntegral inc / n) +-- where aux !(!sumAge, !sumIncome, n) f = (sumAge + f^.age, sumIncome + f^.capitalGain, n+1) + diff --git a/src/MptcpAnalyzer/Plots/Types.hs b/src/MptcpAnalyzer/Plots/Types.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Plots/Types.hs @@ -0,0 +1,63 @@ +{- +Module: MptcpAnalyzer.Plots.Types +Description : +Maintainer : matt +Portability : Linux + +Trying to come up with a userspace abstraction for MPTCP path management + +-} +module MptcpAnalyzer.Plots.Types ( + PlotSettings(..) + , ArgsPlots(..) + , LivePlotTcpSettings(..) +) +where + +import Data.Word (Word32) +import MptcpAnalyzer.ArtificialFields +import MptcpAnalyzer.Stream +import MptcpAnalyzer.Types +import Net.IP +import Net.Tcp +import Net.Stream + +-- | Settings shared by all plots +data PlotSettings = PlotSettings { + -- | Where to save the file + plsOut :: Maybe String + -- | To override the default title + , plsTitle :: Maybe String + -- | Whether to display the result + , plsDisplay :: Bool + -- , ploLabelx :: String + -- , ploLabely :: String + , plsMptcp :: Bool -- ^ True if it's an mptcp plot (as opposed to TCP) + } + -- parser.add_argument('--display', action="store", default="term", choices=["term", "gui", "no"], + +data LivePlotTcpSettings = LivePlotTcpSettings { + lvsFilter :: TcpConnection -- ^the connection to filter + , lvsTestPcap :: (Maybe FilePath) -- ^a pcap file used to test, when set, ignore interface name + , lvsDestination :: (Maybe ConnectionRole) -- % to filter destination + , lvsIfName :: String -- ^Interface name +} + +-- | The list of possible plots +data ArgsPlots = + + -- actually valid for MPTCP too + -- | Expects a filename/streamId attr and maybe destination + ArgsPlotTcpAttr + FilePath -- ^ The pcap file to load + Word32 + String -- ^ The parameter to plot (e.g., "seq", "ack") + (Maybe ConnectionRole) + -- | + -- @pcap1 pcap2 stream1 stream2 destinations whether its tcp or mptcp + | ArgsPlotOwdTcp (PcapMapping Tcp) (Maybe ConnectionRole) + | ArgsPlotOwdMptcp (PcapMapping Mptcp) (Maybe ConnectionRole) + -- Maybe filename + -- TODO use LivePlotTcpSettings instead ? + | ArgsPlotLiveTcp LivePlotTcpSettings + | ArgsPlotLiveMptcp LivePlotTcpSettings diff --git a/src/MptcpAnalyzer/Prelude.hs b/src/MptcpAnalyzer/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Prelude.hs @@ -0,0 +1,19 @@ +module MptcpAnalyzer.Prelude ( + MptcpMembers +) +where + +import Polysemy (Final, Members, Sem, runFinal) +import qualified Polysemy as P +import qualified Polysemy.Embed as P +import qualified Polysemy.IO as P +import qualified Polysemy.Internal as P +import Polysemy.Log (Log) +import qualified Polysemy.Log as Log +import Polysemy.Log.Colog (interpretLogStdout) +import qualified Polysemy.State as P +import Polysemy.Trace (trace) +import qualified Polysemy.Trace as P + +type MptcpMembers = '[Log, P.Trace, P.Embed IO] + diff --git a/src/MptcpAnalyzer/Stats.hs b/src/MptcpAnalyzer/Stats.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Stats.hs @@ -0,0 +1,34 @@ +{-| +Module : MptcpAnalyzer.Stats +Description : Compute statistics on connections +Maintainer : matt +License : GPL-3 +-} + +module MptcpAnalyzer.Stats ( + -- getTcpStatsFromAFrame + -- , getMptcpStats + -- , getSubflowStats + ) +where + +import MptcpAnalyzer.ArtificialFields +import MptcpAnalyzer.Frame +import MptcpAnalyzer.Types +import Net.Mptcp +import Net.Tcp +import Tshark.Fields + + +import Control.Lens hiding (argument) +import qualified Data.Foldable as F +import qualified Data.Map as Map +import Data.Ord (comparing) +import Data.Word (Word32, Word64) +import Frames +import qualified Frames as F +import qualified Frames.InCore as F +import MptcpAnalyzer.Pcap + +-- TODO should be able to update an initial one +-- type Packet = Record HostCols diff --git a/src/MptcpAnalyzer/Stream.hs b/src/MptcpAnalyzer/Stream.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Stream.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +module MptcpAnalyzer.Stream ( + readStreamId + , module M +) +where +import Data.Hashable +import Data.Word (Word32) +import Options.Applicative + +import Net.Stream as M + +-- Phantom types +-- data Mptcp +-- data Tcp +-- data Protocol = Tcp | Mptcp +-- type TcpFlagList = [TcpFlag] + +-- TODO use Word instead +-- newtype StreamId a = StreamId Word32 deriving (Show, Read, Eq, Ord ) deriving Hashable via Word32 +-- type StreamIdTcp = StreamId Tcp +-- type StreamIdMptcp = StreamId Mptcp + +-- showStream :: StreamId a -> Text + + +-- |Can load stream ids from CSV files +readStreamId :: ReadM (StreamId a) +readStreamId = eitherReader $ \arg -> case reads arg of + [(r, "")] -> return $ StreamId r + _ -> Left $ "readStreamId: cannot parse value `" ++ arg ++ "`" diff --git a/src/MptcpAnalyzer/Types.hs b/src/MptcpAnalyzer/Types.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Types.hs @@ -0,0 +1,343 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module MptcpAnalyzer.Types +-- ( +-- -- * types +-- PcapMapping(..) +-- , tcpDest +-- ) +where + +-- Inspired by Frames/demo/missingData +import MptcpAnalyzer.Stream +import Net.Stream +import Net.Bitset (fromBitMask, toBitMask, ToBitMask) +import Net.IP +import Net.IPv6 (IPv6(..)) +import "mptcp-pm" Net.Tcp.Constants (TcpFlag(..)) +import Tshark.Fields +import Tshark.TH + +import Data.Hashable +import qualified Data.Hashable as Hash +import Data.Monoid (First(..)) +import Data.Vinyl (ElField(..), Rec(..), rapply, rmapX, xrec) +import Data.Vinyl.Class.Method +import Data.Vinyl.Functor (Compose(..), (:.)) +import qualified Data.Vinyl.TypeLevel as V + +import qualified Data.Vinyl as V +import Data.WideWord.Word128 +import Data.Word (Word16, Word32, Word64, Word8) +import Frames +import Frames.CSV (ParserOptions(..), QuotingMode(..)) +import Frames.ShowCSV +import Frames.TH +-- (Parseable(..), parseIntish, Parsed(..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import Frames.ColumnTypeable +import Frames.InCore (VectorFor) +import Language.Haskell.TH +import Numeric (readHex) +import qualified Text.Read as T +-- import GHC.TypeLits +import Control.Lens +import Control.Monad (MonadPlus, liftM, mzero) +import qualified Data.Set as Set +import qualified Data.Text as TS +import qualified Data.Text.Lazy.Builder as B +import Data.Typeable (Typeable) +import qualified Frames as F +import GHC.Generics +import GHC.TypeLits (KnownSymbol) +import MptcpAnalyzer.ArtificialFields +import Options.Applicative +import System.Process (ProcessHandle) + + +instance ToBitMask TcpFlag + +{- 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) + + +declarePrefixedColumns "" baseFields + +-- when loading the second pcap to merge, we need to distinguish between the different fields +-- declarePrefixedColumns "test" baseFields +declarePrefixedColumns "" baseFieldsHost2 +declarePrefixedColumns "" baseFieldsSender +declarePrefixedColumns "" baseFieldsReceiver + +-- todo declare it from ArtificialFields ? +-- artificial types, i.e. created by the app and not tshark +declareColumn "tcpDest" ''ConnectionRole +-- | True if host 1 is sender +declareColumn "senderHost" ''Bool +declareColumn "senderDest" ''ConnectionRole +declareColumn "mptcpDest" ''ConnectionRole +declareColumn "packetHash" ''Int +declareColumn "colOwd" ''Double + + +-- TODO check it generates +-- HostCols +genRecordFrom "HostCols" baseFields +-- these are useful when merging different +genRecordFromHeaders "" "HostColsPrefixed" baseFieldsHost2 +-- genExplicitRecord "test" "HostColsPrefixed" baseFieldsHost2 +genRecHashable "HashablePart" baseFields +genRecordFrom "SenderCols" baseFieldsSender +genRecordFrom "ReceiverCols" baseFieldsReceiver + +-- | Represent a mapping between 2 pcaps captured at either end of a connection +-- (i.e., one pcap was captured at the client, the other at the receiver) +data PcapMapping a = PcapMapping { + -- | Host 1 pcap to load + pmapPcap1 :: FilePath + , pmapStream1 :: StreamId a + -- | Host 2 + , pmapPcap2 :: FilePath + , pmapStream2 :: StreamId a + -- , pmapVerbose :: Bool + -- , pmapLimit :: Int -- ^Number of comparisons to show + -- , pmapMptcp :: Bool -- ^Wether it's an MPTCP + } + + +-- row / ManRow +type Packet = Record HostCols +type PacketWithSenderDest = Record (SenderDest ': HostCols) +type PacketWithTcpDest = Record (TcpDest ': HostCols) +-- type PacketWithMptcpDest = Record (MptcpDest ': MptcpDest ': HostCols) + +-- https://stackoverflow.com/questions/14020491/is-there-a-way-of-deriving-binary-instances-for-vinyl-record-types-using-derive?rq=1 +-- forall t s a rs. (t ~ '(s,a) +-- comparable to Storable +deriving instance (KnownSymbol s, Hashable a) => Hashable(ElField '(s, a)) +deriving instance Hashable TcpFlag + +-- | This is only here so we can use hash maps for the grouping step. This should properly be in Vinyl itself. +instance Hashable (F.Record '[]) where + hash = const 0 + {-# INLINABLE hash #-} + hashWithSalt s = const s + {-# INLINABLE hashWithSalt #-} + +instance (V.KnownField t, Hashable (V.Snd t), Hashable (F.Record rs), rs F.⊆ (t ': rs)) => Hashable (F.Record (t ': rs)) where + hashWithSalt s r = s `Hash.hashWithSalt` F.rgetField @t r `Hash.hashWithSalt` F.rcast @rs r + {-# INLINABLE hashWithSalt #-} + +deriving instance Hashable IP + +-- IPv6 is Word128 +deriving instance Generic IPv6 + +deriving instance Hashable Word128 +deriving instance Hashable IPv6 + +-- shadow param +-- @a@ be Tcp / Mptcp +-- @b@ could be the direction +type PcapFrame a = Frame Packet + + +-- | TODO adapt / rename to AFrame ? AdvancedFrames ? +-- GADT ? +data FrameFiltered a rs = FrameTcp { + ffCon :: a + -- StreamConnection b => b + -- Frame of sthg maybe even bigger with TcpDest / MptcpDest + , ffFrame :: Frame rs + } deriving Functor + + +aframeLength :: FrameFiltered a rs -> Int +aframeLength = frameLength . ffFrame + + +-- Helper to pass information across functions +data MyState = MyState { + _stateCacheFolder :: FilePath + , _loadedFile :: Maybe (FrameRec HostCols) -- ^ cached loaded pcap + , _prompt :: String -- ^ Prompt entry + , _sharkdHandle :: Maybe ProcessHandle -- ^ sharkd process handle +} + +makeLenses ''MyState + + + +type OptionList = T.Text + + +-- Used to parse tokens +instance (Read a, Typeable a, Frames.ColumnTypeable.Parseable a) => Frames.ColumnTypeable.Parseable (Maybe a) where + parse txt = case T.null txt of + True -> return $ Definitely Nothing + False -> do + val2 <- val + return $ case val2 of + Possibly x -> Possibly (Just x) + Definitely x -> Definitely (Just x) + where + val :: MonadPlus m => m (Parsed a) + val = parse txt + + -- val2 :: MonadPlus m => m (Parsed (Maybe a)) + -- val2 = Just <$> val + -- case w64 of + -- Left msg -> error $ "could not read " ++ show txt ++ ", error: " ++ msg + -- Right val -> Definitely (Just val) + -- where + -- w64 = T.readEither (T.unpack txt) + + +-- TODO parse based on , +-- instance Frames.ColumnTypeable.Parseable (Maybe OptionList) where +-- parse _ = return $ Definitely Nothing + +instance Frames.ColumnTypeable.Parseable Word16 where + parse = parseIntish +instance Frames.ColumnTypeable.Parseable Word32 where + parse = parseIntish + +instance Frames.ColumnTypeable.Parseable Word64 where + parse = parseIntish + +instance Frames.ColumnTypeable.Parseable IP where + -- parse :: MonadPlus m => T.Text -> m (Parsed a) +-- IP.decode :: Text -> Maybe IP + -- fmap Definitely + parse text = case decode text of + Nothing -> return $ Possibly $ ipv4 0 0 0 0 + Just ip -> return $ Definitely ip + +-- instance Frames.ColumnTypeable.Parseable Word64 where +-- parse = parseIntish + +instance Readable (StreamId a) where + fromText t = case T.readMaybe (T.unpack t) of + Just streamId -> return $ StreamId streamId + Nothing -> mzero + + +instance Frames.ColumnTypeable.Parseable (StreamId Mptcp) where + parse = parseIntish + +instance Frames.ColumnTypeable.Parseable (StreamId Tcp) where + parse = parseIntish + + +-- +parseList :: (MonadPlus m, Typeable a, Frames.ColumnTypeable.Parseable a) => Text -> m (Parsed [a]) +parseList text = fmap Definitely (mapM parse' (T.splitOn "," text)) + +instance Frames.ColumnTypeable.Parseable [Word64] where + -- expected type parse :: MonadPlus m => T.Text -> m (Parsed [a]) + parse = parseList + + +-- could not parse 0x00000002 +-- strip leading 0x +instance Frames.ColumnTypeable.Parseable [TcpFlag] where + parse text = case readHex (T.unpack $ T.drop 2 text) of + -- TODO generate + [(n, "")] -> return $ Definitely $ fromBitMask n + _ -> error $ "TcpFlags: could not parse " ++ T.unpack text + +-- TODO rewrite it as wireshark exposes it, eg, in hexa ? +-- instance ShowCSV [TcpFlag] where +-- -- showCSV :: a -> Text +-- showCSV flagList = T.concat texts +-- where +-- texts = map (T.pack . show .fromEnum) flagList +-- res = toBitMask flagList + +instance ShowCSV [TcpFlag] where + -- showCSV :: a -> Text + showCSV flagList = T.concat texts + where + texts = map (T.pack . show .fromEnum) flagList + res = toBitMask flagList + +instance ShowCSV [Word64] where + -- showCSV :: a -> Text + showCSV seqs = T.intercalate "," texts + where + texts = map (T.pack . show .fromEnum) seqs + +instance ShowCSV IP where + showCSV = encode + +instance ShowCSV Word8 where +instance ShowCSV Word16 where +instance ShowCSV Word32 where +instance ShowCSV Word64 where +instance ShowCSV m => ShowCSV (Maybe m) where + showCSV = \case + Nothing -> "" + Just x -> showCSV x + +-- +instance ShowCSV (StreamId a) where + showCSV (StreamId stream) = showCSV stream + + +-- type ManMaybe = Rec (Maybe :. ElField) ManColumns +-- TODO goal here is to choose the most performant Data.Vector +type instance VectorFor Word8 = V.Vector +type instance VectorFor Word16 = V.Vector +type instance VectorFor Word32 = V.Vector +type instance VectorFor Word64 = V.Vector +type instance VectorFor (Maybe Word8) = V.Vector +type instance VectorFor (Maybe Word16) = V.Vector +type instance VectorFor (Maybe Word32) = V.Vector +type instance VectorFor (Maybe Word64) = V.Vector +type instance VectorFor IP = V.Vector +type instance VectorFor TcpFlagList = V.Vector +type instance VectorFor (StreamId a) = V.Vector + +type instance VectorFor (Maybe Int) = V.Vector +type instance VectorFor (Maybe Bool) = V.Vector +type instance VectorFor (Maybe OptionList) = V.Vector +type instance VectorFor MbMptcpStream = V.Vector +type instance VectorFor ConnectionRole = V.Vector +-- FIX generalize +type instance VectorFor [Word64] = V.Vector +type instance VectorFor (Maybe [Word64]) = V.Vector + + +type TcpFields rs = (TcpSrcPort ∈ rs, TcpDestPort ∈ rs, TcpStream ∈ rs) +type IpFields rs = (IpSource ∈ rs, IpDest ∈ rs) + diff --git a/src/MptcpAnalyzer/Units.hs b/src/MptcpAnalyzer/Units.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Units.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DeriveAnyClass #-} +{- +Module: MptcpAnalyzer.Units +Description : Make it easier to work with units +Maintainer : matt +Portability : Linux + +ecosystem around units is not great, and we have basic needs so let's reimplement some +basic code. +-} +module MptcpAnalyzer.Units ( + -- Types + Bytes(..) + , Timestamp (..) + , Throughput(..) + , Duration(..) + + -- functions + , diffTime + ) +where +import Data.Word (Word32, Word64) + +-- import Data.Time.Units +-- import Data.Time.Units + +-- https://github.com/chrissound/byteunits#readme +data Bytes = Bytes Word64 + +data TimeUnit = Second | MilliSecond | NanoSecond +-- TimeUnit +-- TODO pass unit +data Timestamp = Timestamp Double deriving (Show, Eq, Ord) +data Duration = Duration Double + +instance Show Duration where + -- for now we only measure seconds + show (Duration d) = show d ++ "s" + +-- (-) :: Timestamp -> Timestamp -> Duration +diffTime :: Timestamp -> Timestamp -> Duration +diffTime (Timestamp t1) (Timestamp t2) = Duration (t1 Prelude.- t2) + + + +data Throughput = Throughput Bytes Duration + +instance Show Throughput where + -- WIP + show (Throughput (Bytes bytes) (Duration duration)) = show $ fromIntegral bytes / duration diff --git a/src/MptcpAnalyzer/Utils/Completion.hs b/src/MptcpAnalyzer/Utils/Completion.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Utils/Completion.hs @@ -0,0 +1,335 @@ +{-# LANGUAGE CPP #-} +{-| +Module: MptcpAnalyzer.Utils.Completion +Maintainer : matt +License : GPL-3 + + + missingArgP :: ParseError -> Completer -> m a + errorP :: ParseError -> m a + +parseError peut renvoyer un missingArgP qui du coup aura le completer, qu'on n'a plus qu'a transcrire dans un completer haskeline ! + +-} +module MptcpAnalyzer.Utils.Completion ( + generateHaskelineCompleterFromParserInfo + , completePath + , readFilename +) +where + +import Data.Char (isSpace) +import Data.List (isPrefixOf, isSuffixOf, stripPrefix) +import Data.Maybe (fromJust, fromMaybe, listToMaybe) +import Debug.Trace +import Options.Applicative +import Options.Applicative.Common +import Options.Applicative.Help (Doc, renderPretty) +import Options.Applicative.Help.Chunk +import Options.Applicative.Help.Pretty (displayS) +import Options.Applicative.Internal hiding (Completion) +import Options.Applicative.Types hiding (replacement) +import System.Console.Haskeline + (Completion(..), CompletionFunc, completeFilename, noCompletion) +import System.Console.Haskeline.Completion (listFiles) +-- import Options.Applicative.Help (parserHelp) +import System.IO.Unsafe (unsafePerformIO) +import System.Posix (fileExist, getFileStatus, isRegularFile) + +defaultCompleteFunc :: CompletionFunc IO +defaultCompleteFunc = completeFilename + + +-- | We use unsafePerformIO to work around optparse-applicative limitation +readFilename :: String -> Either String FilePath +readFilename path = + -- fileExist seems to consider files and folders alike + let exists = unsafePerformIO $ do + t <- fileExist path + if t then + getFileStatus path >>= return . isRegularFile + else + return False + in + case exists of + True -> +#ifdef DEBUG_COMPLETION + trace "right path" +#endif + Right path + False -> +#ifdef DEBUG_COMPLETION + trace ("path " ++ path ++ " DOES NOT EXIST (returning Left)") +#endif + Left "Path does not exist" + +-- optparse2haskelineCompletion +oa2hl :: CompletionItem -> Completion +oa2hl (CompletionItem replacement' display' isFinished') = + Completion replacement' display' isFinished' + +hl2oa :: Completion -> CompletionItem +hl2oa (Completion replacement' display' isFinished') = + CompletionItem replacement' display' isFinished' + +-- newtype Completer = Completer +-- { runCompleter :: String -> IO [String] } +-- type CompletionFunc m = (String, String) -> m (String, [Completion]) +-- "optparse-applicative" wrapper around haskelinec>s 'completeFilename' +-- The first 'String' argument is the contents of the line to the left of the cursor, +-- reversed. +-- The second 'String' argument is the contents of the line to the right of the cursor. +-- TODO this should accept a filter ? like for which type of file +completePath :: Completer +completePath = mkCompleter $ \entry -> do + -- case words entry of + -- [] -> "" + -- x -> tail + (_, completions) <- +#ifdef DEBUG_COMPLETION + trace "completeFilename called with entry" +#endif + completeFilename (reverse entry, "") + let completions' = map hl2oa completions + putStrLn $ "completePath called !! with entry: [" ++ entry ++ "]" + return $ +#ifdef DEBUG_COMPLETION + trace ("completions: " ++ show completions) +#endif + completions' + +-- drop 1 was for progname ? +-- TODO make it so that it returns [Completion] instead +-- runParser and runParserStep +haskelineCompletionQuery :: ParserInfo a -> ParserPrefs + -> [String] + -- ^ words , Should be Args ? + -- -> Int + -- ^ current word (to remove ?) + -> String -> IO [Completion] +haskelineCompletionQuery pinfo pprefs ws rest = case runCompletion compl pprefs of + Just (Left (SomeParser p, a)) -> +#ifdef DEBUG_COMPLETION + trace "listing options\n" +#endif + list_options a p + -- terminal case + Just (Right c) -> +#ifdef DEBUG_COMPLETION + trace "terminal completer\n" +#endif + run_completer c + Nothing -> +#ifdef DEBUG_COMPLETION + trace "runCompletion into Nothing\n" +#endif + return [] + where + --current word + -- runParserInfo te renvoie une (Completion a) + -- drop 1 looks necesary here ? + compl = +#ifdef DEBUG_COMPLETION + traceShow ("Passing args " ++ show ws ++ "\n") +#endif + runParserInfo pinfo ws + -- runParserInfo calls runParserFully + -- compl = runParserInfo pinfo ws + -- trace ("runCompleter: ws=" ++ show ws ++ " i=" ++ show i ++ "ws''= " ++ show ws'' ++ " rest=" ++ show rest) + + list_options a + = fmap concat + . sequence + . mapParser (opt_completions a) + + -- Prior to 0.14 there was a subtle bug which would + -- mean that completions from positional arguments + -- further into the parse would be shown. + -- + -- We therefore now check to see that + -- hinfoUnreachableArgs is off before running the + -- completion for position arguments. + -- + -- For options and flags, ensure that the user + -- hasn't disabled them with `--`. + -- opt_completions :: ArgPolicy -> ArgumentReachability -> Option a -> m [Completion] + -- trace ("argPolicy " ++ show argPolicy ++ "\n") + opt_completions argPolicy reachability opt = case optMain opt of + OptReader ns _ _ + | argPolicy /= AllPositionals -> +#ifdef DEBUG_COMPLETION + trace "unreachable OptReader\n" +#endif + return . add_opt_help opt $ show_names ns + -- trace "optreader\n" + | otherwise -> return [] + FlagReader ns _ + | argPolicy /= AllPositionals -> +#ifdef DEBUG_COMPLETION + trace "unreachableflag reader\n" +#endif + return . add_opt_help opt $ show_names ns + -- trace "flagreader\n" + | otherwise -> return [] + ArgReader rdr + | argumentIsUnreachable reachability -> +#ifdef DEBUG_COMPLETION + trace "unreachable\n " +#endif + return [] + -- TODO restore arg Reader with file autocomplete + -- | otherwise -> return [] + -- trace "argreader\n" + | otherwise -> run_completer (crCompleter rdr) + -- >>= \x -> return $ Completion x "argreader help" True + CmdReader _ ns p + | argumentIsUnreachable reachability -> +#ifdef DEBUG_COMPLETION + trace "unreachable cmdreader\n" +#endif + + return [] + -- trace "cmdreader\n" + | otherwise -> return . add_cmd_help p $ filter_names ns + + -- When doing enriched completions, add any help specified + -- to the completion variables (tab separated). + add_opt_help :: Functor f => Option a -> f String -> f Completion + add_opt_help opt = fmap $ \o -> + let h = unChunk $ optHelp opt + len = 80 + in maybe (Completion o "option help" True) (\h' -> Completion o (o ++ "\t" ++ render_line len h' ) False) h + + -- When doing enriched completions, add the command description + -- to the completion variables (tab separated). + add_cmd_help :: Functor f => (String -> Maybe (ParserInfo a)) -> f String -> f Completion + add_cmd_help p = fmap $ \cmd -> let + len = 80 + h = p cmd >>= unChunk . infoProgDesc + in + -- if there is a parser info we add help + maybe (Completion cmd "cmd help" True) (\h' -> Completion cmd (cmd ++ "\t" ++ render_line len h') False) h + + show_names :: [OptName] -> [String] + show_names = filter_names . map showOption + + -- We only want to show a single line in the completion results description. + -- If there was a line break, it would come across as a different completion + -- possibility. + render_line :: Int -> Doc -> String + render_line len doc = case lines (displayS (renderPretty 1 len doc) "") of + [] -> "" + [x] -> x + x : _ -> x ++ "..." + + filter_names :: [String] -> [String] + filter_names = filter (isPrefixOf currentArg) + + -- TODO fix the arg + run_completer :: Completer -> IO [Completion] + -- (fromMaybe "" (listToMaybe [currentArg])) + run_completer c = + +#ifdef DEBUG_COMPLETION + trace ("running completer against " ++ currentArg) +#endif + runCompleter c currentArg >>= return . map oa2hl + + currentArg :: String + currentArg = case ws of + [] -> "" + ws' -> last ws' + +-- The output String is the unused portion of the left half of the line, reversed. +-- type CompletionFunc m = (String, String) -> m (String, [Completion] +-- haskeline System.Console.Haskeline.Completion +-- Performs completions from the given line state. The first String argument is the +-- contents of the line to the left of the cursor, reversed. The second String +-- argument is the contents of the line to the right of the cursor. The output +-- String is the unused portion of the left half of the line, reversed +generateHaskelineCompleterFromParserInfo :: ParserPrefs -> ParserInfo a -> CompletionFunc IO +generateHaskelineCompleterFromParserInfo parserPrefs pinfo = + \(rleft, right) -> + let + leftArgs = words $ reverse rleft + fullArgs = reverse rleft ++ right + fullArgs' = words fullArgs ++ if trailingSpace then [""] else [] + currentWord = last leftArgs + parserResult = +#ifdef DEBUG_COMPLETION + trace ("\nParsing args " ++ reverse rleft ++ "\n") +#endif + + execParserPure parserPrefs pinfo leftArgs + trailingSpace = " " `isSuffixOf` fullArgs + leftRes = case fullArgs' of + [] -> "" + _ -> mconcat (init fullArgs') ++ if trailingSpace then " " else "" + in do + candidates <- haskelineCompletionQuery pinfo parserPrefs (trace ("\n" ++ show fullArgs' ++ "\n" ) fullArgs') "" + -- putStrLn $ "Returned candidates : " ++ show candidates + + -- now onto converting candidates + -- TODO stripper le commonPrefix + -- map (\x -> System.Console.Haskeline.Completion x x False) + + + pure (" " ++ reverse leftRes, map ( + id + -- \x -> x { replacement = fromMaybe "error" (stripPrefix currentWord (display x)) } + ) + candidates) + + +-- runParserInfo on a subparser only goes one level deep +-- so we need to run it twice +-- customHaskelineParser :: ParserInfo a -> ParserPrefs -> CompletionFunc IO +-- customHaskelineParser pinfo pprefs = +-- \(rleft, right) -> +-- let +-- leftArgs = words $ reverse rleft +-- -- TODO rename to str +-- fullArgs = reverse rleft ++ right +-- fullArgs' = words fullArgs ++ if trailingSpace then [""] else [] +-- in do +-- if len fullArgs' > 1 then +-- generateHaskelineCompleterFromParserInfo ( + +-- generateHaskelineCompleterFromParserInfo = haskelineCompletionQuery +-- generateHaskelineCompleterFromParser pprefs (infoParser pinfo) + +-- generateHaskelineCompleterFromParser :: ParserPrefs -> Parser a -> CompletionFunc IO +-- generateHaskelineCompleterFromParser parserPrefs (OptP opt) = generateHaskelineCompleterFromOption opt +-- generateHaskelineCompleterFromParser _ _ = error "undefined " + +-- argument completeWith / complete +placeholderCompletion :: System.Console.Haskeline.Completion +placeholderCompletion = Completion "itworked" "display" False + +constCompletionFunc :: CompletionFunc IO +constCompletionFunc (left, right) = pure ("worked", [placeholderCompletion]) + +-- generateHaskelineCompleterFromOption :: Option a -> CompletionFunc IO +-- generateHaskelineCompleterFromOption (Option main _properties) = generateHaskelineCompleterFromOptreader main + +-- generateHaskelineCompleterFromOptreader :: OptReader a -> CompletionFunc IO +-- generateHaskelineCompleterFromOptreader (CmdReader mbGrpCommand arrStr func) = +-- \(rleft, right) -> let +-- filtered = filter (isPrefixOf prefix) arrStr +-- -- genCompletions :: String -> IO [Completion] +-- -- genCompletions prefix = map (genCompletion prefix) +-- -- "TODO show help for " ++ +-- genCompletion entry = Completion entry ( entry) True +-- prefix = reverse rleft +-- longestCommonPrefix entries = rleft +-- completions = map (genCompletion) filtered +-- in +-- -- TODO call execParserPure ParserInfo a +-- trace "completion called" (pure ( +-- -- return longest common prefixes +-- "", completions +-- )) + +-- -- TODO convert the C +-- -- generateHaskelineCompleterFromOptreader (ArgReader (CReader completer _)) = +-- generateHaskelineCompleterFromOptreader _ = error "undefined generateHaskelineCompleterFromOptreader" diff --git a/src/MptcpAnalyzer/Utils/Text.hs b/src/MptcpAnalyzer/Utils/Text.hs new file mode 100644 --- /dev/null +++ b/src/MptcpAnalyzer/Utils/Text.hs @@ -0,0 +1,12 @@ +module MptcpAnalyzer.Utils.Text ( + -- completeInitialCommand + -- generateHaskelineCompleterFromParser + tshow +) +where + +import qualified Data.Text as TS + +tshow :: Show a => a -> TS.Text +tshow = TS.pack . Prelude.show + diff --git a/src/Net/Mptcp/Stats.hs b/src/Net/Mptcp/Stats.hs new file mode 100644 --- /dev/null +++ b/src/Net/Mptcp/Stats.hs @@ -0,0 +1,204 @@ +{-| +Module : Net.Mptcp.Stats +Description : Compute basic MPTCP statistics +Maintainer : matt +License : GPL-3 +-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE StandaloneDeriving #-} +module Net.Mptcp.Stats ( + TcpSubflowUnidirectionalStats(..) + , MptcpUnidirectionalStats(..) + , getMptcpStats + , getMptcpGoodput + , getMptcpStatsDuration + , getSubflowStats + , showMptcpUnidirectionalStats +) +where + +import MptcpAnalyzer.ArtificialFields +import MptcpAnalyzer.Pcap +import MptcpAnalyzer.Stream +import MptcpAnalyzer.Units + +import qualified Data.Map as Map +import Net.Mptcp.Connection +import Net.Tcp +import Net.Tcp.Stats + +import Data.Either (fromRight) +import Data.Text (Text) +import qualified Data.Text as T + +import Control.Lens +import Control.Lens hiding (argument) +import Data.List (sort, sortBy, sortOn) +import Data.Map (Map, fromList, mapKeys) +import qualified Data.Map as Map +import Data.Maybe (catMaybes, fromJust) +import Data.Set (toList) +import Data.Vinyl +import Data.Word (Word32, Word64) +import qualified Data.Foldable as F +import qualified Frames as F +import qualified Frames.InCore as F +import MptcpAnalyzer.Types +import MptcpAnalyzer.Utils.Text +import Control.Exception (assert) +-- import MptcpAnalyzer.Pcap (addTcpDestinationsToAFrame) + +-- | Useful to show DSN +data TcpSubflowUnidirectionalStats = TcpSubflowUnidirectionalStats { + -- tssStats :: TcpUnidirectionalStats + tssStats :: TcpUnidirectionalStats + , tssMinDsn :: Word64 + , tssMaxDsn :: Word64 + } deriving Show +-- newtype TcpSubflowUnidirectionalStats = TcpSubflowUnidirectionalStats + +instance Semigroup TcpSubflowUnidirectionalStats where + -- (<>) :: a -> a -> a + -- TODO this does nothing + (<>) a b = a + +instance Monoid TcpSubflowUnidirectionalStats where + mempty = TcpSubflowUnidirectionalStats { + tssStats = mempty + , tssMinDsn = 0 + , tssMaxDsn = 0 + } + + +-- | Holds MPTCP application level statistics for one direction +data MptcpUnidirectionalStats = MptcpUnidirectionalStats { + musDirection :: ConnectionRole + , musApplicativeBytes :: Word64 + , musMaxDsn :: Word64 + , musMinDsn :: Word64 + , musSubflowStats :: Map MptcpSubflow TcpSubflowUnidirectionalStats + } deriving Show + +instance Monoid MptcpUnidirectionalStats where + mempty = MptcpUnidirectionalStats RoleServer 0 0 0 mempty + +instance Semigroup MptcpUnidirectionalStats where + -- TODO fix + (<>) s1 s2 = assert (musDirection s1 == musDirection s2) + s1 { + musMaxDsn = max (musMaxDsn s1) (musMaxDsn s2) + , musMinDsn = min (musMinDsn s1) (musMinDsn s2) + -- , musApplicativeBytes = musApplicativeBytes s1 ++ musApplicativeBytes s2 + } + + + -- ''' application data = goodput = useful bytes ''' + -- ''' max(dsn)- min(dsn) - 1''' + -- mptcp_application_bytes: Byte + + -- '''Total duration of the mptcp connection''' + -- mptcp_duration: datetime.timedelta + -- subflow_stats: List[TcpUnidirectionalStats] + + -- @property + -- def mptcp_throughput_bytes(self) -> Byte: + -- ''' sum of total bytes transferred ''' + -- return Byte(sum(map(lambda x: x.throughput_bytes, self.subflow_stats))) + +-- |Goodput is defined as the amount of effective data exchanged over time +-- I.e., (maxDsn - minDsn) / (Mptcp communication Duration) +getMptcpGoodput :: MptcpUnidirectionalStats -> Throughput +getMptcpGoodput s = Throughput (Bytes $ musApplicativeBytes s) ((getMptcpStatsDuration s) ^. _1) + +-- fromIntegral + +-- | return max - min across subflows +getMptcpStatsDuration :: MptcpUnidirectionalStats -> (Duration, Timestamp, Timestamp) +getMptcpStatsDuration s = (diffTime end start, start, end) + where + start = Timestamp $ head $ sort starts + end = Timestamp $ last $ sort ends + -- min of + -- TODO get min + starts = map (tusStartTime . tssStats) (Map.elems $ musSubflowStats s) + -- take the maximum + ends = map (tusEndTime . tssStats) (Map.elems $ musSubflowStats s) + + +-- | TcpSubflowUnidirectionalStats +getSubflowStats :: + (TcpSeq F.∈ rs, F.RecVec rs, RelTime F.∈ rs, TcpLen F.∈ rs + , PacketId F.∈ rs + , IpSource ∈ rs, IpDest ∈ rs, TcpSrcPort ∈ rs, TcpDestPort ∈ rs, TcpStream ∈ rs + -- , TcpDest F.∈ rs + ) + => FrameFiltered MptcpSubflow (F.Record rs) -> ConnectionRole -> TcpSubflowUnidirectionalStats +getSubflowStats aframe role = TcpSubflowUnidirectionalStats { + tssStats = getTcpStatsFromAFrame (addTcpDestinationsToAFrame aframe') role + , tssMinDsn = 0 + , tssMaxDsn = 0 + } + where + aframe' = FrameTcp (sfConn $ ffCon aframe) (ffFrame aframe) + + +-- mptcp_compute_throughput est bourrin il calcule tout d'un coup, je veux avoir une version qui marche iterativement +-- | Generates Stats for one direction only +getMptcpStats :: + ( + -- TcpDest F.∈ rs + MptcpDsn F.∈ rs, TcpSeq F.∈ rs, IpDest F.∈ rs, IpSource F.∈ rs + , TcpLen F.∈ rs + , PacketId F.∈ rs + , TcpDestPort F.∈ rs, MptcpRecvToken F.∈ rs + , TcpFlags F.∈ rs, TcpSrcPort F.∈ rs, TcpStream F.∈ rs, RelTime F.∈ rs + , rs F.⊆ HostCols + , F.RecVec rs + ) + => FrameFiltered MptcpConnection (F.Record rs) + -> ConnectionRole + -> MptcpUnidirectionalStats +getMptcpStats (FrameTcp mptcpConn frame) dest = + MptcpUnidirectionalStats { + musDirection = dest + , musApplicativeBytes = getSeqRange maxDsn minDsn + , musMaxDsn = maxDsn + , musMinDsn = minDsn + -- we need the stream id / FrameFiltered MptcpSubflow (Record rs) + , musSubflowStats = Map.fromList $ map (\sf -> (sf, getStats dest sf)) (toList $ _mpconSubflows mptcpConn) + } + where + -- buildTcpConnectionFromStreamId :: SomeFrame -> StreamId Tcp -> Either String (FrameFiltered TcpConnection Packet) + -- traverse a set + getStats role sf = let + sfFrame = fromRight (error "could not build sfFrame") (buildSubflowFromTcpStreamId frame (conTcpStreamId $ sfConn sf)) + -- sfFrame' = addTcpDestinationsToAFrame sfFrame + in + getSubflowStats sfFrame role + + -- frame = addTcpDestToFrame $ ffFrame aframe + -- these return Maybes + -- minSeq = minimum (F.toList $ view tcpSeq <$> frame) + -- maxSeq = maximum $ F.toList $ view tcpSeq <$> frame + + maxTime = maximum $ F.toList $ view relTime <$> frame + minTime = minimum $ F.toList $ view relTime <$> frame + + -- dsn_range, dsn_max, dsn_min = transmitted_seq_range(df, "dsn") + -- mbRecs = map recMaybe mergedRes + -- justRecs = catMaybes mbRecs + -- in + -- (toFrame justRecs, []) + + dsns = catMaybes $ F.toList $ view mptcpDsn <$> frame + + -- mergedPcapToFrame + maxDsn, minDsn :: Word64 + maxDsn = maximum dsns + + minDsn = minimum dsns + +showMptcpUnidirectionalStats :: MptcpUnidirectionalStats -> Text +showMptcpUnidirectionalStats stats = T.unlines [ + "Max/min dsn: " <> tshow (musMinDsn stats) <> "/" <> tshow (musMaxDsn stats) <> " towards " <> tshow (musDirection stats) + ] diff --git a/src/Net/Tcp/Stats.hs b/src/Net/Tcp/Stats.hs new file mode 100644 --- /dev/null +++ b/src/Net/Tcp/Stats.hs @@ -0,0 +1,323 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE StandaloneDeriving #-} +{- +Module: Net.Tcp.Stats +Description : Compute basic TCP statistics +Maintainer : matt +Portability : Linux +-} + +module Net.Tcp.Stats ( + TcpUnidirectionalStats (..) + , getTcpGoodput + , getTcpThroughput + , getTcpSeqRange + , getTcpStatsFromAFrame + , getSeqRange + , showTcpUnidirectionalStats +) +where + +import MptcpAnalyzer.ArtificialFields +import MptcpAnalyzer.Types +import MptcpAnalyzer.Utils.Text +import Net.Tcp.Connection + +import qualified Control.Foldl as L +import Control.Lens hiding (argument) +import qualified Data.Map as Map +import Data.Maybe (fromJust) +import Data.Word (Word32, Word64) +-- import Data.ByteUnits + +import qualified Data.Foldable as F +import Data.Ord (comparing) +import qualified Data.Text as T +import Frames +import qualified Frames as F +import qualified Frames.InCore as F + +type Byte = Int + +-- tus = tcp Unidrectional Stats +data TcpUnidirectionalStats = TcpUnidirectionalStats { + -- sum of tcplen / should be the same for tcp/mptcp + -- Include redundant packets contrary to ''' + -- tusThroughput :: Byte + + -- tusStartPacketId :: Word64 + -- , tusEndPacketId :: Word64 + tusNrPackets :: Int + -- duration + -- , tusDuration :: Double + + -- TODO convert to date ? + , tusStartTime :: Double + , tusEndTime :: Double + + -- For now = max(tcpseq) - minx(tcpseq). Should add the size of packets''' + -- , tusMinSeq :: Word32 + -- , tusMaxSeq :: Word32 + + -- transferred bytes + -- , tusCumulativeBytes :: Map Word64 Word16 + , tusMinSeq :: Word32 + , tusSndUna :: Word32 + , tusSndNext :: Word32 + -- , tusReinjectedBytes :: Map Word64 Word16 + , tusReinjectedBytes :: Word32 -- ^Amount of reinjected bytes + -- , tusUniqueBytes :: Word64 + + -- , tusMinAck :: Word32 + -- , tusMaxAck :: Word32 + + -- application data = goodput = useful bytes ''' + -- TODO move to its own ? / Maybe + -- , mptcp_application_bytes :: Byte + -- , tusThroughputContribution :: Double + -- , tusGoodputContribution :: Double + + -- TODO this should be updated + -- For now = max(tcpseq) - minx(tcpseq). Should add the size of packets''' + -- , tusGoodput :: Byte + } deriving (Show, Eq) + -- deriving Semigroup via WrappedMonoid TcpUnidirectionalStats + +-- deriving instance Semigroup TcpUnidirectionalStats +-- deriving instance Monoid TcpUnidirectionalStats + +instance Semigroup TcpUnidirectionalStats where + -- (<>) :: a -> a -> a + -- TODO this does nothing + (<>) a b = TcpUnidirectionalStats { + -- tusThroughput = 0 + -- tusStartPacketId = min (tusStartPacketId a) (tusStartPacketId b) + -- , tusEndPacketId = max (tusEndPacketId a) (tusEndPacketId b) + tusNrPackets = tusNrPackets a + tusNrPackets b + , tusStartTime = min (tusStartTime a) (tusStartTime b) + , tusEndTime = max (tusEndTime a) (tusEndTime b) + -- let it to 0 for now + , tusMinSeq = 0 + + -- TODO should be max of seen acks + , tusSndUna = max (tusSndUna a) (tusSndUna b) + , tusSndNext = max (tusSndNext a) (tusSndNext b) + , tusReinjectedBytes = 0 + -- , tusSnd = 0 + -- , tusNumberOfPackets = mempty + } + +instance Monoid TcpUnidirectionalStats where + mempty = TcpUnidirectionalStats { + -- tusThroughput = 0 + -- tusStartPacketId = 0 -- (frameRow frame 0) ^. packetId + -- , tusEndPacketId = 0 -- (frameRow frame (frameLength frame - 1)) ^. packetId + tusNrPackets = 0 + , tusStartTime = 0 + , tusEndTime = 0 + , tusMinSeq = 0 -- TODO fill it + + -- TODO should be max of seen acks + , tusSndUna = 0 + , tusSndNext = 0 + , tusReinjectedBytes = 0 + -- , tusSnd = 0 + -- , tusNumberOfPackets = mempty + } + +-- | TODO check boundaries etc +getSeqRange :: Num a => a -> a + -> a + -- -> (a, a, a) +-- getSeqRange maxSeq minSeq = (maxSeq - minSeq + 1, maxSeq, minSeq) +getSeqRange maxSeq minSeq = maxSeq - minSeq + 1 + + + +-- TODO add a Functor to FilteredFrame +genTcpStats :: Frame Packet -> TcpUnidirectionalStats +genTcpStats aframe = TcpUnidirectionalStats { + + -- TODO we should run a minmax instead + -- tusStartPacketId = minPktId + -- , tusEndPacketId = maxPktId + tusNrPackets = frameLength aframe + -- maxTime = maximum $ F.toList $ view relTime <$> frame + -- minTime = minimum $ F.toList $ view relTime <$> frame + + -- We could just take first and last + , tusStartTime = minTime + , tusEndTime = maxTime + + , tusMinSeq = 0 -- not used + , tusSndUna = maxUna + , tusSndNext = 0 + , tusReinjectedBytes = 0 + } + where + -- we could use the Statistics vector if we could use the + (minPktId, maxPktId) = case L.fold ((,) <$> L.minimum <*> L.maximum) $ F.toList $ view packetId <$> aframe of + (Just pmin, Just pmax) -> (pmin, pmax) + _otherwise -> error "Could not find either min or max" + + (minTime, maxTime) = case L.fold ((,) <$> L.minimum <*> L.maximum) $ F.toList $ view relTime <$> aframe of + (Just pmin, Just pmax) -> (pmin, pmax) + _otherwise -> error "Could not find either min or max" + + (minSeq, maxSeq) = case L.fold ((,) <$> L.minimum <*> L.maximum) $ F.toList $ view tcpSeq <$> aframe of + (Just pmin, Just pmax) -> (pmin, pmax) + _otherwise -> error "Could not find either min or max" + + -- TODO + (minUna, maxUna) = case L.fold ((,) <$> L.minimum <*> L.maximum) $ F.toList $ view tcpAck <$> aframe of + (Just pmin, Just pmax) -> (pmin, pmax) + _otherwise -> error "Could not find either min or max" + + + +-- | Destination should have been filtered upstream +-- see @genTcpDestFrame@ +-- TODO suffix fromFrame +getTcpStatsFromAFrame :: ( + TcpSeq F.∈ rs + , F.RecVec rs + , TcpLen F.∈ rs, RelTime F.∈ rs + , PacketId F.∈ rs + -- disabled for now, we assumed it's filtered upstream + , TcpDest F.∈ rs + ) + => FrameFiltered TcpConnection (F.Record rs) + -> ConnectionRole + -> TcpUnidirectionalStats +getTcpStatsFromAFrame aframe dest = + if frameLength frame == 0 then + mempty + else + TcpUnidirectionalStats { + -- tusThroughput = 0 + -- tusStartPacketId = 0 -- (frameRow frame 0) ^. packetId + -- , tusEndPacketId = 0 -- (frameRow frame (frameLength frame - 1)) ^. packetId + tusNrPackets = frameLength frame + , tusStartTime = minTime + , tusEndTime = maxTime + -- TODO fill it + , tusMinSeq = minSeq + + -- TODO should be max of seen acks + , tusSndUna = maxSeqRow ^. tcpSeq + fromIntegral ( maxSeqRow ^. tcpLen) :: Word32 + , tusSndNext = maxSeqRow ^. tcpSeq + fromIntegral ( maxSeqRow ^. tcpLen ) :: Word32 + , tusReinjectedBytes = 0 + } + where + frame = F.filterFrame (\x -> x ^. tcpDest == dest) (ffFrame aframe) + + -- these return Maybes + -- I need to find its id and add tcpSize afterwards + -- TODO use minimumBy + minSeq = case F.toList $ view tcpSeq <$> frame of + [] -> 0 + l -> minimum l + -- maxSeq = maximum $ F.toList $ view tcpSeq <$> frame + + -- $ F.toList $ view tcpSeq <$> frame + maxSeqRow = F.maximumBy (comparing (^. tcpSeq)) frame + + -- compareRows x y = if (x ^. tcpSeq) (y ^. tcpSeq) + + maxTime = maximum $ F.toList $ view relTime <$> frame + minTime = minimum $ F.toList $ view relTime <$> frame + + +-- byteValue +getTcpSeqRange :: TcpUnidirectionalStats -> Double +getTcpSeqRange s = + fromIntegral (tusSndUna s - tusMinSeq s - 1) + +-- | Computes throughput +-- TODO should return a quantity with number +getTcpThroughput :: TcpUnidirectionalStats -> Double +getTcpThroughput s = + if tusNrPackets s == 0 then 0 + else fromIntegral (tusSndUna s - tusMinSeq s - 1) / (tusEndTime s - tusStartTime s) + +-- | Computes goodput +getTcpGoodput :: TcpUnidirectionalStats -> Double +getTcpGoodput s = + fromIntegral (tusSndUna s - tusMinSeq s + 1 - tusReinjectedBytes s) / (tusEndTime s - tusStartTime s) + +showTcpUnidirectionalStats :: TcpUnidirectionalStats -> Text +showTcpUnidirectionalStats stats = + T.unlines [ + "Timestamps:" <> tshow (tusStartTime stats) <> " -> " <> tshow (tusEndTime stats) + , "Reinjected bytes: " <> tshow (tusReinjectedBytes stats) + , "Current goodput: " <> tshow (getTcpGoodput stats) + ] + + -- duration = maxTime - minTime + + + +-- No instance for (Ord (Frames.Frame.Frame GHC.Word.Word32)) +-- instance Ord a => Ord (Frame a) +-- def transmitted_seq_range(df, seq_name): +-- ''' +-- test +-- ''' +-- log.debug("Computing byte range for sequence field %s", seq_name) + +-- sorted_seq = df.dropna(subset=[seq_name]).sort_values(by=seq_name) +-- log.log(mp.TRACE, "sorted_seq %s", sorted_seq) + +-- seq_min = sorted_seq.loc[sorted_seq.first_valid_index(), seq_name] +-- last_valid_index = sorted_seq.last_valid_index() +-- seq_max = sorted_seq.loc[last_valid_index, seq_name] \ +-- + sorted_seq.loc[last_valid_index, "tcplen"] + +-- # -1 because of SYN +-- # seq_range = seq_max - seq_min - 1 +-- seq_range = seq_max - seq_min - 1 + +-- msg = "seq_range ({}) = {} (seq_max) - {} (seq_min) - 1" +-- log.log(mp.TRACE, msg.format(seq_range, seq_max, seq_min)) + +-- return seq_range, seq_max, seq_min + + + -- where + -- packetStreams = filterStreamPackets frame streamId (Just role) + -- log.debug("Getting TCP stats for stream %d", tcpstreamid) + -- assert destination in ConnectionRoles, "destination is %r" % type(destination) + + -- df = rawdf[rawdf.tcpstream == tcpstreamid] + -- if df.empty: + -- raise MpTcpException("No packet with tcp.stream == %d" % tcpstreamid) + + -- df2 = df + + -- log.debug("df2 size = %d" % len(df2)) + -- log.debug("Looking at role %s" % destination) + -- # assume it's already filtered ? + -- sdf = df2[df2.tcpdest == destination] + -- bytes_transferred = Byte(sdf["tcplen"].sum()) + -- assert bytes_transferred >= 0 + + -- # -1 to account for SYN + -- tcp_byte_range, seq_max, seq_min = transmitted_seq_range(sdf, "tcpseq") + + -- # print(sdf["abstime"].head()) + -- # print(dir(sdf["abstime"].dt)) + -- # print(sdf["abstime"].dt.end_time) + -- times = sdf["abstime"] + -- tcp_duration = times.iloc[-1] - times.iloc[0] + -- # duration = sdf["abstime"].dt.end_time - sdf["abstime"].dt.start_time + + -- assert tcp_byte_range is not None + + -- return TcpUnidirectionalStats( + -- tcpstreamid, + -- tcp_duration=tcp_duration, + -- throughput_bytes=bytes_transferred, + -- # FIX convert to int because Byte does not support np.int64 + -- tcp_byte_range=Byte(tcp_byte_range) + -- ) diff --git a/src/Tshark/Capture.hs b/src/Tshark/Capture.hs new file mode 100644 --- /dev/null +++ b/src/Tshark/Capture.hs @@ -0,0 +1,303 @@ +{-# LANGUAGE CPP #-} +{- +Module: Tshark.Capture +Description : Description +Maintainer : matt +Portability : Linux +-} +module Tshark.Capture +-- ( +-- tsharkLoop +-- ) +where + +-- mptcpanalyzer imports +import Net.Tcp.Connection +import Net.Tcp.Constants +import MptcpAnalyzer.Stream (StreamIdMptcp) +import Net.Mptcp.Connection +import Tshark.Live +import MptcpAnalyzer.Types +import Tshark.Main (csvDelimiter, defaultTsharkPrefs) +import MptcpAnalyzer.Pcap +import MptcpAnalyzer.ArtificialFields +import Net.Tcp.Stats (getTcpStatsFromAFrame) +import Net.Mptcp.Stats + +import Control.Monad.State (MonadState(get), StateT, gets, modify') +import qualified Data.Map.Strict as Map +import GHC.IO.Handle +import Pipes (Effect) +import Frames +import qualified Data.Text as T +import Frames.CSV (columnSeparator, ReadRec, ParserOptions, readRow, defaultParser) +import qualified Pipes as P +import qualified Pipes.Parse as P +import qualified Pipes.Prelude as P +import Pipes ((>->)) +import Pipes hiding (Proxy) +import Debug.Trace (trace, traceShow, traceShowId) +import System.Console.ANSI +import Data.Vinyl.Functor (getCompose) +import qualified Control.Foldl as Foldl +import Control.Lens ((^.), (.~)) +import qualified Data.Set as Set +import Data.Maybe (fromJust) +import Data.Either (rights) +import Control.Arrow (first) +import qualified Data.Foldable as F +import qualified Frames as F +import qualified Frames.InCore as F + + + +pipeTableEitherOpt' :: (Monad m, ReadRec rs) + => ParserOptions + -> P.Pipe T.Text (Rec (Either T.Text :. ElField) rs) m () +pipeTableEitherOpt' opts = do + -- when (isNothing (headerOverride opts)) (() <$ P.await) + P.map (readRow opts) + + +-- produceFrameChunks +-- inCoreAoS +-- --capture-comment +-- TODO return the frame/ stats +tsharkLoopTcp :: LiveStatsConfig -> Handle -> Effect (StateT (LiveStatsTcp) IO) () +tsharkLoopTcp lsConfig hout = do + ls <- for (P.fromHandle hout) $ \x -> do + _ <- liftIO $ putStrLn "newLine" + + -- (frame :: FrameRec HostCols) <- lift ( inCoreAoS (pipeLines (try. T.hGetLine) hout >-> pipeTableEitherOpt popts >-> P.map fromEither )) + -- let x2 :: Text = "1633468309.759952583|eno1|2a01:cb14:11ac:8200:542:7cd1:4615:5e05||2606:4700:10::6814:14ec|||||||||||127|||21.118721618||794|1481|51210|0x00000018|31||3300|443|3||" + (frame :: FrameRec HostCols) <- liftIO $ inCoreAoS (yield (T.pack x) >-> pipeTableEitherOpt' popts >-> P.map fromEither ) + -- showFrame [csvDelimiter defaultTsharkPrefs] frame + liftIO $ putStrLn $ showFrame [csvDelimiter defaultTsharkPrefs] frame + let frameWithDest = addTcpDestinationsToAFrame (FrameTcp (lsConnection lsConfig) frame) + + -- stFrame <- gets lsFrame + modify' (updateTcpStats frameWithDest) + -- liftIO $ cursorUp 1 + liveStats <- get + let output = showLiveStatsTcp liveStats + liftIO $ cursorUpLine $ (+) 1 (Prelude.length $ T.lines output) + liftIO clearFromCursorToScreenEnd + liftIO $ (putStrLn . T.unpack) output + + -- liftIO $ (putStrLn . T.unpack . showLiveStatsTcp) ls + pure ls + + where + -- tokenize = tokenizeRow popts + popts = defaultParser { + columnSeparator = T.pack $ [csvDelimiter defaultTsharkPrefs] + } + fromEither x = case recEither x of + Left _txt -> error ( "eitherProcessed failure : " ++ T.unpack _txt) + Right pkt -> pkt + + -- updateStatsFrame :: FrameRec HostCols -> LiveStatsTcp -> LiveStatsTcp + -- updateStatsFrame frame lstats = foldl updateStats lstats frame + updateTcpStats frameWithDest tstats = tstats <> genLiveStatsTcp frameWithDest + + recEither = rtraverse getCompose + +updateMptcpStats :: + ( + -- TcpDest F.∈ rs + MptcpDsn F.∈ rs, TcpSeq F.∈ rs, IpDest F.∈ rs, IpSource F.∈ rs + , TcpLen F.∈ rs + , PacketId F.∈ rs + , TcpDestPort F.∈ rs, MptcpRecvToken F.∈ rs + , TcpFlags F.∈ rs, TcpSrcPort F.∈ rs, TcpStream F.∈ rs, RelTime F.∈ rs + , rs F.⊆ HostCols + , F.RecVec rs + ) + => FrameFiltered MptcpConnection (F.Record rs) +updateMptcpStats = undefined + +-- Tricky function: +-- Contrary to TCP we have to filter on the master subflow but as we can't update the filter as we discover +-- the subflows, we configure tshark to capture all MPTCP traffic and filter it in the application +-- 1/ first we need to find the master subflow +tsharkLoopMptcp :: LiveStatsConfig -> Handle -> Effect (StateT LiveStatsMptcp IO) () +tsharkLoopMptcp config hout = do + -- hSetBuffering hout LineBuffering + -- ls <- for (tsharkProducer hout) $ \x -> do + ls <- for (P.fromHandle hout) $ \x -> do + + -- (frame :: FrameRec HostCols) <- lift ( inCoreAoS (pipeLines (try. T.hGetLine) hout >-> pipeTableEitherOpt popts >-> P.map fromEither )) + -- let x2 :: Text = "1633468309.759952583|eno1|2a01:cb14:11ac:8200:542:7cd1:4615:5e05||2606:4700:10::6814:14ec|||||||||||127|||21.118721618||794|1481|51210|0x00000018|31||3300|443|3||" + (frame :: FrameRec HostCols) <- liftIO $ inCoreAoS (yield (T.pack x) >-> pipeTableEitherOpt' popts >-> P.map fromEither ) + -- showFrame [csvDelimiter defaultTsharkPrefs] frame + liftIO $ putStrLn $ showFrame [csvDelimiter defaultTsharkPrefs] frame + -- if we have no master subflow yet, we should check against it + -- so now we should + mptcpstats <- gets _lsmStats + + -- TODO should be a fmap considering the complexity + modify' (updateStatsFrame frame) + -- liftIO $ cursorUp 1 + liveStatsMptcp <- get + -- showLiveStatsTcp liveStats + let output = showLiveStatsMptcp liveStatsMptcp + + -- liftIO $ cursorUpLine $ (+) 1 (Prelude.length $ T.lines output) + liftIO clearFromCursorToScreenEnd + liftIO $ (putStrLn . T.unpack) output + -- liftIO $ putStrLn $ "length " ++ show (frameLength stFrame) + -- lift $ hPutStrLn stdout "test" + + -- liftIO $ (putStrLn . T.unpack . showLiveStatsTcp) ls + pure ls + + where + -- tokenize = tokenizeRow popts + popts = defaultParser { + columnSeparator = T.pack $ [csvDelimiter defaultTsharkPrefs] + } + fromEither x = case recEither x of + Left _txt -> error ( "eitherProcessed failure : " ++ T.unpack _txt) + Right pkt -> pkt + + recEither = rtraverse getCompose + + + -- expects a frame and a LiveStatsMptcp + updateStatsFrame :: FrameRec HostCols -> LiveStatsMptcp -> LiveStatsMptcp + updateStatsFrame frame lstats = foldl updateStats lstats frame + + updateStats :: LiveStatsMptcp -> Record HostCols -> LiveStatsMptcp + -- case where the master subflow was already identified + updateStats lstats@(LiveStatsMptcp (Just main) _ _ subflows stats) row = + case mbSubflow of + -- Not a registered subflow yet + Nothing -> case row ^. mptcpRecvToken of + Nothing -> +#ifdef DEBUG_CAPTURE + trace "No rcv token" +#endif + lstats + + Just rcvToken -> let + subflow = buildSubflowFromRecord row + in +#ifdef DEBUG_CAPTURE + trace "Rcv token received" +#endif + ( + -- if token of client then subflow initiated by server + if tokenBelongToConnection rcvToken main then + lstats { + _lsmMaster = +#ifdef DEBUG_CAPTURE + trace "Adding new subflow" +#endif + (Just (mptcpConnAddSubflow main subflow)) + + } + else +#ifdef DEBUG_CAPTURE + trace ("ignoring flow " ++ show subflow) +#endif + lstats + ) + Just subflowStats -> + case getSubflowFromStreamId main (row ^. tcpStream) of + Nothing -> error "Could not find the subflow :s " + Just subflow -> let + -- TODO update tcp stats for th + -- TODO change connection staths when seeing dataFin + -- TODO update subflow stats and mptcp stats + -- if row ^. mptcpDataFin + -- subflow = master + tcpAframe :: FrameFiltered TcpConnection Packet + tcpAframe = FrameTcp (sfConn subflow) frame + + newMptcpStats :: LiveStats MptcpUnidirectionalStats Packet + newMptcpStats = genLiveStatsMptcp mptcpAframe + + subflowUpdatedStats :: LiveStatsTcp + subflowUpdatedStats = genLiveStatsTcp (addTcpDestinationsToAFrame tcpAframe) + in +#ifdef DEBUG_CAPTURE + trace "known subflow: update stats" +#endif + (lstats { + -- TODO we should have stats in both direction ! + -- _lsmStats = (lstats ^. lsmStats) <> newMptcpStats + _lsmStats = (lstats ^. lsmStats) <> newMptcpStats + , _lsmSubflows = Map.insert (row ^. tcpStream) (subflowStats <> subflowUpdatedStats) (lstats ^. lsmSubflows) + }) + where + tuple = traceShowId (buildTcpConnectionTupleFromRecord row) + + mptcpAframe :: FrameFiltered MptcpConnection Packet + mptcpAframe = FrameTcp main frame + + frame :: FrameRec HostCols + frame = boxedFrame [row] + mbSubflow = Map.lookup (row ^. tcpStream) (_lsmSubflows lstats) + + + updateStats lstats@(LiveStatsMptcp Nothing (Just clientCfg) (Just serverCfg) _subflows stats) row = error "should not happen" + + -- in updateStats newStats row + -- attempts to fetch client mptcp key/token from the initial syn (mptcp version 0) + updateStats lstats@(LiveStatsMptcp Nothing _ _ _ stats) row = + -- synPackets = filterFrame (\x -> TcpFlagSyn `elem` (x ^. tcpFlags)) streamPackets + if hasClientKey then + -- streamPackets = filterFrame (\x -> x ^. mptcpStream == mympconStreamId) frame + -- subflows = map (buildSubflowFromTcpStreamId frame) (getTcpStreams streamPackets) +#ifdef DEBUG_CAPTURE + trace "SYN FOUND! retreiving client key" +#endif + lstats { + _lsmClient = traceShowId mptcpConfig + , _lsmMaster = finalizeLiveStatsMptcp mptcpConfig (_lsmServer lstats) + , _lsmSubflows = Map.singleton (row ^. tcpStream) (genLiveStatsTcp (FrameTcp (sfConn subflow) mempty)) + -- Set.fromList $ map ffCon (rights subflows) + } + else if isSynAck then + -- lstats & set (traceShowId mptcpConfig) +#ifdef DEBUG_CAPTURE + trace "SYNACK FOUND! retreiving server key" +#endif + lstats { + _lsmServer = traceShowId mptcpConfig + , _lsmMaster = finalizeLiveStatsMptcp (_lsmClient lstats) mptcpConfig + } + else +#ifdef DEBUG_CAPTURE + trace "No syn\n" +#endif + lstats + where + tuple = traceShowId (buildTcpConnectionTupleFromRecord row) + -- tcpAframe = buildA + -- TcpFlagSyn `elem` (row ^. tcpFlags) && + hasClientKey = (row ^. mptcpSendKey ) /= Nothing && lsConnection config == tcpConnectionFromOriented tuple + isSynAck = TcpFlagSyn `elem` (row ^. tcpFlags) && TcpFlagAck `elem` (row ^. tcpFlags) + && lsConnection config == tcpConnectionFromOriented (reverseTcpConnectionTuple tuple) + mptcpConfig = genMptcpEndpointConfigFromRow row + subflow :: MptcpSubflow + subflow = (MptcpSubflow (buildTcpConnectionFromRecord row) Nothing Nothing 0 0 Nothing) + mympconStreamId :: Maybe StreamIdMptcp + mympconStreamId = row ^. mptcpStream + finalizeLiveStatsMptcp :: Maybe MptcpEndpointConfiguration -> Maybe MptcpEndpointConfiguration -> Maybe MptcpConnection + finalizeLiveStatsMptcp mclientCfg mserverCfg = case (mclientCfg, mserverCfg) of + (Just clientCfg, Just serverCfg) -> +#ifdef DEBUG_CAPTURE + trace "FINALIZING MPTCP connection" +#endif + (Just $ MptcpConnection { + -- get it from map.singleton + mpconStreamId = fromJust $ mympconStreamId + -- fromJust $ synAckPacket ^. mptcpSendKey + , _mpconServerConfig = serverCfg + , _mpconClientConfig = clientCfg + -- , mptcpNegotiatedVersion = mptcpVersion (serverCfg) -- TODO fix + -- , mpconSubflows = Set.fromList $ map ffCon (rights subflows) + , _mpconSubflows = Set.singleton subflow + }) + _ -> Nothing diff --git a/src/Tshark/Fields.hs b/src/Tshark/Fields.hs new file mode 100644 --- /dev/null +++ b/src/Tshark/Fields.hs @@ -0,0 +1,144 @@ +{-| +Module : Tshark.Fields +Description : Interface between wireshark output format and haskell +Maintainer : matt + +This module is in charge of loading TCP packets in a haskell format. +This is done by converting between wireshark formats (.pcapng -> .csv) and +using "Frames" to load the resulting data into a frame. + +-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +module Tshark.Fields +where +import Net.Stream +import MptcpAnalyzer.Stream + +import Data.Text (Text) +import Data.Word (Word16, Word32, Word64, Word8) +import Frames.ShowCSV +import GHC.TypeLits (KnownSymbol) +import Language.Haskell.TH (Name, Q) +import Net.IP +import Net.IPv6 (IPv6(..)) +import "mptcp-pm" Net.Tcp.Constants (TcpFlag(..)) + +import Data.Map (Map, fromList, mapKeys) +-- Phantom types +-- data Mptcp +-- data Tcp +-- -- data Protocol = Tcp | Mptcp + +-- -- TODO use Word instead +-- newtype StreamId a = StreamId Word32 deriving (Show, Read, Eq, Ord ) + +-- type StreamIdTcp = StreamId +-- type StreamIdMptcp = StreamId + +type TcpFlagList = [TcpFlag] +type MbPacketIdList = Maybe [Word64] + + +type MbMptcpStream = Maybe StreamIdMptcp +type MbMptcpSendKey = Maybe Word64 +-- TODO convert to a Word8 +type MbMptcpVersion = Maybe Int +type MbMptcpExpectedToken = Maybe Word32 + +type MbMptcpDsn = Maybe Word64 +type MbMptcpDack = Maybe Word64 +type MbWord64 = Maybe Word64 + + +data TsharkFieldDesc = TsharkFieldDesc { + tfieldFullname :: Text + -- ^Full wireshark name of the field + , tfieldColType :: Name + -- ^Haskell type so that we can generate the proper raw type via templateHaskell + , tfieldLabel :: Maybe String + -- ^Pretty field name used as label in plots + , tfieldHashable :: Bool + -- ^Wether to take into account this field when creating the hash of a packet + -- see hash + } + + +type FieldDescriptions = Map Text TsharkFieldDesc + +type MbWord32 = Maybe Word32 + + +-- TODO add this ? +-- data Field = FieldPacketId | FieldInterfaceName + +-- MUST BE KEPT IN SYNC WITH Pcap.hs HostCols ORDER INCLUDED ! +baseFields :: FieldDescriptions +baseFields = fromList [ + ("packetId", TsharkFieldDesc "frame.number" ''Word64 Nothing False) + , ("interfaceName", TsharkFieldDesc "frame.interface_name" ''Text Nothing False) + , ("absTime", TsharkFieldDesc "frame.time_epoch" ''Double Nothing False) + , ("relTime", TsharkFieldDesc "frame.time_relative" ''Double Nothing False) + , ("ipSource", TsharkFieldDesc "_ws.col.ipsrc" ''IP (Just "source ip") True) + , ("ipDest", TsharkFieldDesc "_ws.col.ipdst" ''IP (Just "destination ip") True) + , ("ipSrcHost", TsharkFieldDesc "ip.src_host" ''Text (Just "source ip hostname") False) + , ("ipDstHost", TsharkFieldDesc "ip.dst_host" ''Text (Just "destination ip hostname") False) + , ("tcpStream", TsharkFieldDesc "tcp.stream" ''StreamIdTcp Nothing False) + , ("tcpSrcPort", TsharkFieldDesc "tcp.srcport" ''Word16 Nothing True) + , ("tcpDestPort", TsharkFieldDesc "tcp.dstport" ''Word16 Nothing True) + , ("rwnd", TsharkFieldDesc "tcp.window_size" ''Word32 Nothing True) + , ("tcpFlags", TsharkFieldDesc "tcp.flags" ''TcpFlagList Nothing True) + , ("tcpOptionKinds", TsharkFieldDesc "tcp.option_kind" ''Text Nothing True) + , ("tcpSeq", TsharkFieldDesc "tcp.seq" ''Word32 (Just "Sequence number") True) + , ("tcpLen", TsharkFieldDesc "tcp.len" ''Word16 (Just "Tcp Len") True) + , ("tcpAck", TsharkFieldDesc "tcp.ack" ''Word32 (Just "Tcp ACK") True) + + , ("tsval", TsharkFieldDesc "tcp.options.timestamp.tsval" ''MbWord32 (Just "Timestamp val") True) + , ("tsecr", TsharkFieldDesc "tcp.options.timestamp.tsecr" ''MbWord32 (Just "Timestamp echo-reply") True) + + -- could be computed from the sendKey + , ("mptcpExpectedToken", TsharkFieldDesc "mptcp.expected_token" ''MbMptcpExpectedToken (Just "Expected token") True) + + , ("mptcpStream", TsharkFieldDesc "mptcp.stream" ''MbMptcpStream Nothing False) + , ("mptcpSendKey", TsharkFieldDesc "tcp.options.mptcp.sendkey" ''MbWord64 Nothing True) + , ("mptcpRecvKey", TsharkFieldDesc "tcp.options.mptcp.recvkey" ''MbWord64 Nothing True) + , ("mptcpRecvToken", TsharkFieldDesc "tcp.options.mptcp.recvtok" ''MbMptcpExpectedToken Nothing True) + -- TODO bool + , ("mptcpDataFin", TsharkFieldDesc "tcp.options.mptcp.datafin.flag" ''MbWord64 Nothing True) + , ("mptcpVersion", TsharkFieldDesc "tcp.options.mptcp.version" ''MbMptcpVersion Nothing True) + , ("mptcpDack", TsharkFieldDesc "mptcp.ack" ''MbWord64 (Just "DataAck") True) + , ("mptcpDsn", TsharkFieldDesc "mptcp.dsn" ''MbWord64 (Just "Data Sequence Number") True) + + -- these ones are experimental + , ("relatedMappings", TsharkFieldDesc "mptcp.related_mapping" ''MbWord64 Nothing False) + , ("reinjectionOf", TsharkFieldDesc "mptcp.reinjection_of" ''MbPacketIdList Nothing False) + , ("reinjectedIn", TsharkFieldDesc "mptcp.reinjection_of" ''MbPacketIdList Nothing True) + ] + +-- fakeBaseFields :: FieldDescriptions +-- fakeBaseFields = [ +-- ("fakePacketId", TsharkFieldDesc "frame.number" ''Word64 Nothing False) +-- , ("fakeInterfaceName", TsharkFieldDesc "frame.interface_name" ''Text Nothing False) +-- ] +-- fakeBaseFields2 :: FieldDescriptions +-- fakeBaseFields2 = prefixFields "fake_" fakeBaseFields + +-- TODO +prefixFields :: Text -> FieldDescriptions -> FieldDescriptions +prefixFields prefix descs = + -- map (\(name, field) -> (prefix<>name , field)) + mapKeys (\name -> prefix<>name) descs + +-- this should actually be host2 +baseFieldsHost2 :: FieldDescriptions +baseFieldsHost2 = prefixFields "test_" baseFields + + +baseFieldsSender :: FieldDescriptions +baseFieldsSender = prefixFields "snd_" baseFields + +baseFieldsReceiver :: FieldDescriptions +baseFieldsReceiver = prefixFields "rcv_" baseFields diff --git a/src/Tshark/Interfaces.hs b/src/Tshark/Interfaces.hs new file mode 100644 --- /dev/null +++ b/src/Tshark/Interfaces.hs @@ -0,0 +1,40 @@ +{-| +Module : Tshark.Interfaces +Description : List host interfaces +Maintainer : matt +License : GPL-3 +-} +module Tshark.Interfaces ( + listInterfaces +) +where + +import Polysemy +import Polysemy.Embed +import Polysemy.Log (Log) +import qualified Polysemy.Log as Log +import System.Exit +import System.IO +import System.Process + + +-- listInterfaces :: (Members [Log, Embed IO ] m) => Sem m (ExitCode, [String]) +-- | List network interfaces (just their names) that are visible by tshark +listInterfaces :: IO (ExitCode, [String]) +listInterfaces = + -- defaultTsharkPrefs + let + (RawCommand bin args) = (RawCommand "tshark" [ "--list-interfaces" ]) + createProc :: CreateProcess + createProc = (proc bin args) { std_out = CreatePipe } + in do + (_, mbHout, mbHerr, ph) <- createProcess_ "error" createProc + exitCode <- waitForProcess ph + -- TODO do it only in case of error ? + case mbHout of + Nothing -> error "no out" + Just hout -> do + out <- hGetContents hout + -- err <- hGetContents herr + return (exitCode, map (head. tail . words) (lines out)) + diff --git a/src/Tshark/Live.hs b/src/Tshark/Live.hs new file mode 100644 --- /dev/null +++ b/src/Tshark/Live.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-| +Module: Tshark.Live +Description : Load incrementally a PCAP into a frame +Maintainer : matt +Portability : Linux +-} +module Tshark.Live ( + showLiveStatsTcp + , showLiveStatsMptcp + , LiveStats(..) + , LiveStatsTcp + , LiveStatsConfig(..) + , LiveStatsMptcp(..) + , lsmMaster, lsmSubflows, lsmStats + , mkLiveStatsMptcp + , genLiveStatsMptcp + , genLiveStatsTcp + -- , CaptureSettingsMptcp +) +where + + +import Tshark.Main (csvDelimiter, defaultTsharkPrefs) +import Net.Stream +import Net.Mptcp.Stats + +import Data.Text as T +import qualified Data.Map.Strict as Map +import Control.Lens + +import GHC.IO.Handle +import Pipes ((>->)) +import Pipes hiding (Proxy) +-- import Control.Monad.Primitive +import Control.Exception (IOException, try) +import Control.Monad (liftM, unless, when) +import Data.Maybe (isNothing) +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T +import qualified Data.Map.Strict as Map +import Data.Vinyl.Functor (Compose(..), (:.)) +import Debug.Trace (trace, traceShow, traceShowId) +import Frames +import Frames.CSV + ( ParserOptions + , ReadRec + , columnSeparator + , defaultParser + , headerOverride + , pipeTableEitherOpt + , pipeTableMaybeOpt + , readRecEither + , readRow + , tokenizeRow + ) +import Frames.Exploration +import MptcpAnalyzer.Types (HostCols, Packet, PacketWithTcpDest) +import qualified Pipes as P +import qualified Pipes.Parse as P +import qualified Pipes.Prelude as P +import qualified Pipes.Safe as P + +import Control.Monad.State (MonadState(get), StateT, gets, modify') +import Control.Monad.State.Lazy (execStateT) +import Data.Text.IO (hPutStrLn) +import MptcpAnalyzer (FrameFiltered(ffFrame)) +import MptcpAnalyzer.ArtificialFields +import MptcpAnalyzer.Pcap (addTcpDestinationsToAFrame) +import MptcpAnalyzer.Types (FrameFiltered(FrameTcp)) +import Net.Mptcp.Stats (MptcpUnidirectionalStats) +import Net.Mptcp.Connection (MptcpConnection(MptcpConnection)) +import Net.Mptcp.Stats (MptcpUnidirectionalStats, showMptcpUnidirectionalStats, TcpSubflowUnidirectionalStats) +import Net.Tcp (TcpConnection) +import Net.Tcp.Stats + (TcpUnidirectionalStats, getTcpStatsFromAFrame, showTcpUnidirectionalStats) +import System.Console.ANSI +import System.IO (stdout) +import Net.Mptcp.Connection +import qualified Data.Set as Set +import GHC.Word (Word64, Word32) +import MptcpAnalyzer.Utils.Text + + +-- -- +--------+-- A 'Producer' that yields 'String's +-- -- | | +-- -- | | +-- Every monad transformer has a base monad. +-- -- | | | This time the base monad is 'IO'. +-- -- | | | +-- -- | | | +-- Every monadic action has a return value. +-- -- | | | | This action returns '()' when finished +-- -- v v v v +-- stdinLn :: Producer String IO () +-- stdinLn = do +-- eof <- lift isEOF -- 'lift' an 'IO' action from the base monad +-- unless eof $ do +-- res <- lift getLine +-- yield res -- 'yield' the 'String' +-- stdinLn -- Loop + +-- loop :: Effect IO () +-- loop = for stdinLn $ \x -> do -- Read this like: "for str in stdinLn" +-- lift $ putStrLn x + +-- | Opens a file (in 'P.MonadSafe') and repeatedly applies the given +-- function to the 'Handle' to obtain lines to yield. Adapted from the +-- moribund pipes-text package. +pipeLines :: P.MonadSafe m + => (Handle -> IO (Either IOException T.Text)) + -> Handle + -> P.Producer T.Text m () +pipeLines pgetLine h = + let loop = do txt <- P.liftIO (pgetLine h) + case txt of + Left _e -> return () + Right y -> P.yield y >> loop + in loop + +-- | Produce lines of 'T.Text'. +-- produceTextLines :: P.MonadSafe m => FilePath -> P.Producer T.Text m () +-- produceTextLines = pipeLines (try . T.hGetLine) + +-- | Show live stats TCP +-- showLiveStatsTcp :: LiveStatsTcp -> Text +-- showLiveStatsTcp stats = T.unlines [ +-- showLiveStats (SomeStats stats) +-- , showTcpUnidirectionalStats (lsStats stats) +-- ] + +data SomeStats where + SomeStats :: LiveStats a b -> SomeStats + + +showLiveStatsTcp :: LiveStatsTcp -> Text +showLiveStatsTcp liveStats = + T.unlines ( + [ "Completed ?: " <> tshow (lsHasFinished liveStats) ] + -- ++ if lsDestination liveStats == RoleServer then else [] + ++ ["Showing towards server: ", showTcpUnidirectionalStats (lsForwardStats liveStats)] + -- ++ if lsDestination liveStats == RoleClient then else [] + ++ ["Showing towards client: ", showTcpUnidirectionalStats (lsBackwardStats liveStats)] + ) + + + +-- type UpdateFrameFunc a b = Frame a -> Frame a -> (Frame a, b) + +-- | Hold information on a connection +-- data LiveStats = LiveStats { +-- -- lsCon :: MptcpConnection, +-- lsStats :: MptcpUnidirectionalStats +-- , lsPackets :: Int +-- -- , lsFrame :: FrameFiltered TcpConnection Packet +-- , lsFrame :: FrameRec HostCols +-- } + +-- TODO rename to liveplotConfig ? +data LiveStatsConfig = LiveStatsConfig { + lsConnection :: TcpConnection + , lsDestination :: ConnectionRole + } + +-- TODO should be instance of a Monoid ! +-- | for now unidirectional ? +data LiveStats stats packet = LiveStats { + -- lsCon :: MptcpConnection, + lsForwardStats :: stats + , lsBackwardStats :: stats + -- keep to check everything worked fine? else we can retreive the count from lsFrame + , lsPackets :: Int + -- , lsConnection :: TcpConnection + , lsFrame :: Frame packet + -- , lsFrame :: FrameFiltered con packet + , lsHasFinished :: Bool + -- ^ True once it sees a FIN + -- , lsFrame :: FrameRec HostCols + } + +instance Semigroup stats => Semigroup (LiveStats stats packets) where + (<>) a b = LiveStats { + lsForwardStats = lsForwardStats a <> lsForwardStats b + , lsBackwardStats = lsBackwardStats a <> lsBackwardStats b + , lsPackets = lsPackets a + lsPackets b + , lsFrame = lsFrame a <> lsFrame b + , lsHasFinished = (lsHasFinished a) || (lsHasFinished b) + } + + +instance Monoid stats => Monoid (LiveStats stats packets) where + mempty = LiveStats { + lsForwardStats = mempty + , lsBackwardStats = mempty + -- keep to check everything worked fine? else we can retreive the count from lsFrame + , lsPackets = 0 + -- , lsConnection :: TcpConnection + , lsFrame = mempty + -- , lsFrame :: FrameFiltered con packet + , lsHasFinished = False + } + +type LiveStatsTcp = LiveStats TcpUnidirectionalStats Packet + +-- data LiveStatsTcp = LiveStatsTcp { +-- _lstConn :: Maybe TcpConnection +-- , _lstStats :: LiveStats TcpUnidirectionalStats Packet +-- } +-- type LiveStatsMptcp = LiveStats MptcpUnidirectionalStats MptcpConnection Packet + +-- should be richer +data LiveStatsMptcp = LiveStatsMptcp { + -- tcpStreamId + _lsmMaster :: Maybe MptcpConnection + + , _lsmClient :: Maybe MptcpEndpointConfiguration + -- ^ Key / Token + , _lsmServer :: Maybe MptcpEndpointConfiguration + -- ^ (Key, Token) + , _lsmSubflows :: Map.Map StreamIdTcp LiveStatsTcp + -- (TcpSubflowUnidirectionalStats, TcpSubflowUnidirectionalStats) + -- ^ TODO these should be subflow stats (dss/dsn) + , _lsmStats :: LiveStats MptcpUnidirectionalStats Packet + } + +makeLenses ''LiveStatsMptcp + +-- |Search for the master subflow +-- TODO could +getMasterSubflow :: [MptcpSubflow] -> Maybe MptcpSubflow +getMasterSubflow l = case Prelude.filter (isNothing . sfJoinToken) l of + [] -> Nothing + (x:_) -> Just x + +-- helper to create LiveStatsMptcp +mkLiveStatsMptcp :: LiveStatsMptcp +mkLiveStatsMptcp = LiveStatsMptcp { + _lsmMaster = Nothing + , _lsmClient = Nothing + , _lsmServer = Nothing + , _lsmSubflows = mempty + , _lsmStats = mempty + } +-- type CaptureSettingsMptcp = LiveStatsMptcp + +-- TODO +genLiveStatsTcp :: FrameFiltered TcpConnection PacketWithTcpDest -> LiveStatsTcp +genLiveStatsTcp frameWithDest@(FrameTcp _ frame) = let + forwardFrameWithDest = getTcpStatsFromAFrame frameWithDest RoleServer + backwardFrameWithDest = getTcpStatsFromAFrame frameWithDest RoleClient + in (mempty :: LiveStatsTcp) { + lsPackets = frameLength frame + -- , lsFrame = frame + , lsForwardStats = let + merged = + -- trace ("FRAMEWITH DEST\n" ++ showFrame [csvDelimiter defaultTsharkPrefs] (ffFrame frameWithDest) ++ "\n " ++ show forwardFrameWithDest) + forwardFrameWithDest + in merged + , lsBackwardStats = backwardFrameWithDest + } + + +genLiveStatsMptcp :: FrameFiltered MptcpConnection Packet -> LiveStats MptcpUnidirectionalStats Packet +genLiveStatsMptcp mptcpAframe = (mempty :: LiveStats MptcpUnidirectionalStats Packet) { + lsPackets = frameLength $ ffFrame mptcpAframe + , lsFrame = ffFrame mptcpAframe + , lsForwardStats = getMptcpStats mptcpAframe RoleServer + , lsBackwardStats = getMptcpStats mptcpAframe RoleClient + } + + +showLiveStatsMptcp :: LiveStatsMptcp -> Text +showLiveStatsMptcp stats = T.unlines [ + "Forward: " <> showMptcpUnidirectionalStats (lsForwardStats $ stats ^. lsmStats) + , "Backward: " <> showMptcpUnidirectionalStats (lsBackwardStats $ stats ^. lsmStats) + ] + +showLiveStats :: SomeStats -> Text +showLiveStats (SomeStats liveStats) = + T.unlines [ + "Number of packets: " <> tshow (lsPackets liveStats) + ] + + +-- tsharkProducer :: Handle -> Producer Text TsharkMonad () +-- tsharkProducer hout = do +-- liftIO $ trace ("show hout " ++ show hout) hSetBuffering hout NoBuffering +-- output <- liftIO $ trace "hgetline" hGetLine hout +-- trace "yield" yield (T.pack output) +-- tsharkProducer hout + +---- Accept as input the different handles +--readTsharkOutputAndPlotIt :: Handle -> Handle -> IO () +--readTsharkOutputAndPlotIt hout herr = do +-- -- use pipeTableEitherOpt to parse +-- output <- hGetContents hout +-- putStrLn output diff --git a/src/Tshark/Main.hs b/src/Tshark/Main.hs new file mode 100644 --- /dev/null +++ b/src/Tshark/Main.hs @@ -0,0 +1,145 @@ +{-| +Module : Tshark.Main +Description : Interface between wireshark output format and haskell +Maintainer : matt + + +WIRESHARK_CONFIG_DIR' + +-} +module Tshark.Main ( + TsharkParams(csvDelimiter, tsharkReadFilter) + , generateCsvCommand + , defaultTsharkPrefs + , defaultTsharkOptions + , genReadFilterFromTcpConnection + , genReadFilterMptcpFromMptcpConnection +) +where + +import Data.List (intercalate) +import qualified Data.Text as T +import MptcpAnalyzer.ArtificialFields (ConnectionRole(RoleClient, RoleServer)) +import qualified Net.IP +import Net.Tcp (TcpConnection(..)) +import System.Process + +-- http://acowley.github.io/Frames/#orgf328b25 +defaultTsharkOptions :: [(String, String)] +defaultTsharkOptions = [ + -- TODO join these + ("gui.column.format", intercalate "," [ "Time","%At","ipsrc","%s","ipdst","%d"]), + -- "tcp.relative_sequence_numbers": True if tcp_relative_seq else False, + ("tcp.analyze_sequence_numbers", "true"), + ("mptcp.analyze_mappings", "true"), + ("mptcp.relative_sequence_numbers", "true"), + ("mptcp.intersubflows_retransmission", "true"), + -- # Disable DSS checks which consume quite a lot + ("mptcp.analyze_mptcp", "true") + ] + + +defaultTsharkPrefs :: TsharkParams +defaultTsharkPrefs = TsharkParams { + tsharkBinary = "tshark", + tsharkOptions = defaultTsharkOptions + , csvDelimiter = '|' + , tsharkReadFilter = Just "mptcp or tcp and not icmp" + , tsharkProfile = Nothing + } + +showIP :: Net.IP.IP -> String +showIP = T.unpack . Net.IP.encode + + +-- |One way filter +-- genReadFilterUnidirectional :: +-- genReadFilterUnidirectional = + +-- genReadFilterBidirectional :: +-- genReadFilterBidirectional = + +-- |Create a tshark read filter from a 'TcpConnection' +genReadFilterFromTcpConnection :: + TcpConnection + -> Maybe ConnectionRole -- ^If we care about direction (ignored for now) + -> String +genReadFilterFromTcpConnection con dest = + case dest of + Just RoleClient -> + -- TODO should depend on destination + "tcp and ip.src==" ++ (showIP . conTcpClientIp) con ++ " and ip.dst==" ++ (showIP . conTcpServerIp) con + ++ " and tcp.srcport==" ++ show (conTcpClientPort con) ++ " and tcp.dstport==" ++ show (conTcpServerPort con) + Just RoleServer -> + "tcp and ip.src==" ++ (showIP . conTcpServerIp) con ++ " and ip.dst==" ++ (showIP . conTcpClientIp) con + ++ " and tcp.srcport==" ++ show (conTcpServerPort con) ++ " and tcp.dstport==" ++ show (conTcpClientPort con) + + -- error "not implemented" + -- TODO 2 requretes srcport dstport puis alterne + _nodestination -> "tcp and ip.addr==" ++ (showIP . conTcpClientIp) con ++ " and ip.addr==" ++ (showIP . conTcpServerIp) con + ++ " and tcp.port==" ++ show (conTcpServerPort con) ++ " and tcp.port==" ++ show (conTcpClientPort con) + +-- |Create a tshark read filter from a 'MptcpConnection' +-- genReadFilterFromMptcpConnection :: MptcpConnection -> String +-- genReadFilterFromMptcpConnection con = + + +-- we cant update the filter on the fly so we need to look at all the mptcp traffic +-- and match on master subflow +genReadFilterMptcpFromMptcpConnection :: String +genReadFilterMptcpFromMptcpConnection = "mptcp" + + + +-- | Basic wireshark settings to enforce reproducible results across users +data TsharkParams = TsharkParams { + tsharkBinary :: String, + -- |(Name, Value) of tshark options, see 'defaultTsharkOptions' + tsharkOptions :: [(String, String)], + -- | Flags to add on the command line + -- tsharkFlags :: [String], + -- | How to separate the different fields + csvDelimiter :: Char + -- | for instance "mptcp" or "tcp" + , tsharkReadFilter :: Maybe String + + -- | Path towards the tshark profile to use (passed as `tshark -C ...`) + , tsharkProfile :: Maybe FilePath + } + + +-- |Generate the tshark command to export a pcap into a csv +generateCsvCommand :: [T.Text] -- ^Fields to exports e.g., "mptcp.stream" + -> Either String FilePath -- ^ (interface, path towards the pcap file) + -> TsharkParams + -> CmdSpec +generateCsvCommand fieldNames source tsharkParams = + RawCommand (tsharkBinary tsharkParams ) args + where + -- for some reasons, -Y does not work so I use -2 -R instead + -- quote=d|s|n Set the quote character to use to surround fields. d uses double-quotes, s + -- single-quotes, n no quotes (the default). + -- the -2 is important, else some mptcp parameters are not exported + start = [ + "-E", "separator=" ++ [csvDelimiter tsharkParams] + ] ++ (case source of + Right pcapFilename -> ["-r", pcapFilename] + Left ifname -> ["-i", ifname]) + + + args :: [String] + args = (start ++ opts ++ readFilter ) ++ map T.unpack fields + + opts :: [String] + opts = foldr (\(opt, val) l -> l ++ ["-o", opt ++ ":" ++ val]) [] (tsharkOptions tsharkParams) + + readFilter :: [String] + readFilter = case tsharkReadFilter tsharkParams of + Just x -> (case source of + Right pcapFilename -> ["-2", "-R"] + Left ifname -> ["-Y"]) ++ [x] + Nothing -> [] + + fields :: [T.Text] + fields = ["-T", "fields"] + ++ Prelude.foldr (\fieldName l -> ["-e", fieldName] ++ l) [] fieldNames diff --git a/src/Tshark/Sharkd.hs b/src/Tshark/Sharkd.hs new file mode 100644 --- /dev/null +++ b/src/Tshark/Sharkd.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE OverloadedStrings #-} +-- +-- +-- Format of request listed at +module Tshark.Sharkd ( + + defaultSocketPath + , launchSharkd + , connectToSharkd + , loadFile + ) +where + +import Network.Socket +import Network.Socket.ByteString +import Data.Aeson +import Data.Aeson.Encode.Pretty +import Data.Aeson.Extra.Merge (lodashMerge) +import System.Process hiding (runCommand) +import qualified Control.Exception as E +import Data.ByteString.Lazy (toStrict) +import GHC.IO.Handle +import Control.Concurrent +import qualified Data.ByteString as S +import Foreign (Ptr) +import Foreign.C (CChar) +import Data.Aeson.Encoding (encodingToLazyByteString) + + +defaultSocketPath :: FilePath +defaultSocketPath = "/tmp/sharkd.sock" + +basicPayload :: String -> Series +basicPayload method = + "method" .= toJSON method + <> "jsonrpc" .= toJSON ("2.0" :: String) + <> "id" .= toJSON (1 ::Int) + -- , "params" .= object [ + -- "file" .= pcapPath + -- ] + + + +basicPayloadStr :: String -> String +basicPayloadStr inside = "{'jsonrpc': '2.0', 'id': 1, 'method':'info'}" + + +-- | Launches the wireshark daemon +launchSharkd :: FilePath -- ^ Unix socket path + -> IO () +launchSharkd socketPath = let + createProc :: CreateProcess + createProc = (proc "sharkd" [ socketPath ]) { + delegate_ctlc = True + } + in do + putStrLn $ "Launching " ++ show createProc + (_, _, mbHerr, ph) <- createProcess createProc + pure () + -- waitForProcess ph + + +-- | +-- serializingConfig :: Config +-- serializingConfig = defConfig { confCompare = compare } + +connectToSharkd :: FilePath -> IO () +connectToSharkd = undefined + +-- TODO should return a Either String Value instead ? +sendRequestToSharkd :: FilePath -> Encoding -> IO (Either String Value) +sendRequestToSharkd sockPath payload = do + E.bracketOnError (socket AF_UNIX Stream defaultProtocol) close $ \sock -> do + -- setSocketOption sock ReuseAddr 1 + -- withFdSocket sock setCloseOnExecIfNeeded + -- sock <- socket AF_UNIX Stream defaultProtocol + putStrLn $ "connecting to socket " ++ show sockPath + + connect sock (SockAddrUnix sockPath) + + putStrLn "connected" + -- m <- newEmptyMVar + -- forkIO $ (listenForResponse h m) + putStrLn $ "sending payload " ++ show payload + let bsPayload = (toStrict $ encodingToLazyByteString payload ) <> "\n" + putStrLn $ "sending payload " ++ show bsPayload + sendAll sock bsPayload + putStrLn "sent" + bs <- recv sock 1024 + putStrLn "recv" + print bs + return $ eitherDecodeStrict bs + where + -- socket AF_UNIX Stream defaultProtocol + addr = defaultHints { addrFamily = AF_UNIX, addrAddress = SockAddrUnix sockPath } + +-- | +-- {"req":"load","file":"c:/traces/Contoso_01/web01/web01_00001_20161012151754.pcapng"} +loadFile :: FilePath -> FilePath -> IO () +loadFile pcapPath sockPath = + + sendRequestToSharkd sockPath (pairs payload) >> return () + where + payload = basicPayload "load" <> paramsPayload + paramsPayload = + "params" .= object [ + "file" .= pcapPath + ] + +-- this works +getInfo :: FilePath -> IO () +getInfo sockPath = sendRequestToSharkd sockPath (pairs payload) >> return () + where + payload = basicPayload "info" + +-- {"req":"status"} + +-- getStatus :: Socket -> IO () +-- getStatus sock = sendRequestToSharkd defaultSocketPath payload >> return () +-- where +-- payload = object [ +-- "req" .= toJSON ("status" :: String) +-- ] + +-- {"req":"frames","filter":"frame.number<=20"} +-- getFrames +-- getFrames + diff --git a/src/Tshark/TH.hs b/src/Tshark/TH.hs new file mode 100644 --- /dev/null +++ b/src/Tshark/TH.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Tshark.TH ( + declarePrefixedColumns + , genExplicitRecord + , genRecordFrom + , genRecordFromHeaders + , genRecHashable +) +where + +import Tshark.Fields + +import Control.Arrow (first, second) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64) +import GHC.TypeLits +import Language.Haskell.TH +import Net.IP +-- import Language.Haskell.TH.Syntax +import Data.Vinyl () +import Language.Haskell.TH.Syntax (Q, sequenceQ) +-- for ( (:->)()) +import Frames.Col () +-- ((:->)) +import Frames +import Frames.TH hiding (rowTypeName, tablePrefix) +-- import Frames +import Control.Monad (foldM) +import Data.Char (toLower) +import Data.Map (mapWithKey, toList) +import qualified Data.Map as Map +import Data.Proxy (Proxy(..)) +import Frames.Utils + + +-- WARN the behavior here differs from Frames +declarePrefixedColumns :: Text -> FieldDescriptions -> DecsQ +declarePrefixedColumns prefix fields = do + foldM toto mempty (toList fields) + where + -- acc ++ + toto acc (colName, field) = do + -- Note: Frames.declarePrefixedColumn doesn't prefix the colName but the accessors ! + -- expects colName lensPrefix type + t <- declarePrefixedColumn (prefix <> colName) prefix (tfieldColType field) + return $ acc ++ t + +-- TODO search frames.TH +-- Generates a '[ ] +-- la solution est dans tableTypesText' +-- Generate a FieldRec +-- TODO rename +genRecordFrom :: String -> FieldDescriptions -> DecsQ +genRecordFrom = genRecordFromHeaders "" + +-- rename to explicit / upstream +-- ici on presuppose que les colonnes existrent deja en fait ? +genRecordFromHeaders :: String -> String -> FieldDescriptions -> DecsQ +genRecordFromHeaders tablePrefix rowTypeName fields = genExplicitRecord tablePrefix rowTypeName converted + where + converted = map (\(name, field) -> (name, tfieldColType field)) (toList fields) + +-- mergedFields :: [(String, Name)] +-- FieldDescriptions +-- tablePrefix here consists in the lenses but not the actual column names +genExplicitRecord :: String -> String -> [(Text, Name)] -> Q [Dec] +genExplicitRecord tablePrefix rowTypeName fields = do + (colTypes, colDecs) <- second concat . unzip + <$> mapM (uncurry mkColDecs) headers + -- let recTy = TySynD (mkName rowTypeName) [] (recDec colTypes) + let recTy = TySynD (mkName rowTypeName) [] (qqDec colTypes) + return [recTy] + where + -- colTypes = map (\(name, field) -> (name, colType field)) fields + -- TODO headers + -- headers :: [(Text, Type)] + headers = zip colNames (repeat (ConT ''T.Text)) + -- colNames :: [Text] + colNames = map fst fields + mkColDecs colNm colTy = do + let safeName = T.unpack (sanitizeTypeName colNm) + mColNm <- lookupTypeName (tablePrefix ++ safeName) + case mColNm of + Just n -> pure (ConT n, []) + Nothing -> colDec (T.pack tablePrefix) rowTypeName colNm (Right colTy) + + +genRecHashable :: String -> FieldDescriptions -> DecsQ +genRecHashable prefix fields = genRecordFrom prefix (Map.filter tfieldHashable fields) + +-- inspired from recDec +qqDec :: [Type] -> Type +qqDec = go + where go [] = PromotedNilT + go (t:cs) = AppT (AppT PromotedConsT t) (go cs) + +-- TODO make public in Frames +-- table +-- mkColDecs :: T.Text -> Either (String -> Q [Dec]) Type -> Q (Type, [Dec]) +-- mkColDecs colNm colTy = do +-- let tablePrefix = "" +-- let rowTypeName = "toto" +-- let safeName = tablePrefix ++ (T.unpack . sanitizeTypeName $ colNm) +-- mColNm <- lookupTypeName safeName +-- case mColNm of +-- Just n -> pure (ConT n, []) -- Column's type was already defined +-- Nothing -> colDec (T.pack tablePrefix) rowTypeName colNm colTy + + +-- | Generate a column type. +-- recDecExplicit :: [(T.Text, Q Type)] -> Q Type +-- recDecExplicit = appT [t|Record|] . go +-- where go [] = return PromotedNilT +-- go ((n,t):cs) = +-- [t|($(litT $ strTyLit (T.unpack n)) :-> $t) ': $(go cs) |] + +-- TODO pass on rowTypeName +-- myRowGen :: String -> [(T.Text, TsharkFieldDesc)] -> DecsQ +-- myRowGen rowName fields = do +-- rowType <- recDecExplicit tfields +-- -- let recTy = TySynD (mkName rowTypeName) [] (recDec colTypes) +-- let recTy = TySynD (mkName rowName) [] rowType +-- colDecs <- concat <$> mapM (uncurry $ colDecExplicit (T.pack tablePrefix)) headers +-- return [recTy] +-- where +-- tfields = map (\(colName, fullField) -> (colName, colType fullField)) fields +-- + +--myRow :: [(T.Text, TsharkFieldDesc)] -> RowGen a +--myRow fields = RowGen [] "" "|" "HostCols" [] +-- where +-- -- +-- tfields = map (\(colName, fullField) -> (colName, colType fullField)) fields + +-- type CommonColumns = [Bool, Int, Double, T.Text] +-- rowGen :: FilePath -> RowGen CommonColumns + +-- myColumnUniverse :: String -> FieldDescriptions -> Q [Dec] +-- myColumnUniverse rowTypeName fields = do +-- let colTys = map (\(_name, x) -> colType x) fields +-- colTypes <- tySynD (mkName rowTypeName) [] (promotedTypeList colTys) +-- -- colTypes <- sequenceQ colTys +-- -- f <- sequenceA (colTypes) +-- return [colTypes] +-- -- return $ tySynD colTys +-- -- where +-- -- colTypes :: Q Type + + +promotedTypeList :: [Q Type] -> Q Type +promotedTypeList [] = promotedNilT +promotedTypeList (t:ts) = [t| $promotedConsT $t $(promotedTypeList ts) |] + diff --git a/src/app/Main.hs b/src/app/Main.hs new file mode 100644 --- /dev/null +++ b/src/app/Main.hs @@ -0,0 +1,676 @@ +{-| +Description : Mptcpanalyzer +Maintainer : matt + +* Tutorial + +Accepts as input(s) capture file(s) (\*.pcap) and depending on from there can : + +* list the MPTCP connections in the pcap +* display some statistics on a specific MPTCP connection (list of subflows etc...); +* convert packet capture files (\*.pcap) to \*.csv files +* plot data sequence numbers for all subflows +* `XDG compliance `_, i.e., + |prog| looks for files in certain directories. will try to load your configuration from `$XDG_CONFIG_HOME/mptcpanalyzer/config` +* caching mechanism: mptcpanalyzer compares your pcap creation time and will + regenerate the cache if it exists in `$XDG_CACHE_HOME/mptcpanalyzer/` +* support 3rd party plugins (plots or commands) + +Most commands are self documented and/or with autocompletion. + +Then you have an interpreter with autocompletion that can generate & display plots such as the following: + +![Data Sequence Number (DSN) per subflow plot](examples/dsn.png) + + +How to associate an MP_JOIN to its MPTCP connection ? + +See https://tools.ietf.org/html/draft-ietf-mptcp-rfc6824bis-02#page-40 for mor details: + + + The token is used to identify the MPTCP connection and is a + cryptographic hash of the receiver's key, as exchanged in the initial + MP_CAPABLE handshake (Section 3.1). In this specification, the + + + tokens presented in this option are generated by the SHA-1 ([4], + [17]) algorithm, truncated to the most significant 32 bits. The + token included in the MP_JOIN option is the token that the receiver + of the packet uses to identify this connection; i.e., Host A will + send Token-B (which is generated from Key-B). Note that the hash + generation algorithm can be overridden by the choice of cryptographic + handshake algorithm, as defined in Section 3.1. + + Host A Host B + ------------------------ ---------- + Address A1 Address A2 Address B1 + ---------- ---------- ---------- + | | | + | SYN + MP_CAPABLE(Key-A) | + |--------------------------------------------->| + |<---------------------------------------------| + | SYN/ACK + MP_CAPABLE(Key-B) | + | | | + | ACK + MP_CAPABLE(Key-A, Key-B) | + |--------------------------------------------->| + | | | + | | SYN + MP_JOIN(Token-B, R-A) | + | |------------------------------->| + | |<-------------------------------| + | | SYN/ACK + MP_JOIN(HMAC-B, R-B) | + | | | + | | ACK + MP_JOIN(HMAC-A) | + | |------------------------------->| + | |<-------------------------------| + | | ACK | + + HMAC-A = HMAC(Key=(Key-A+Key-B), Msg=(R-A+R-B)) + HMAC-B = HMAC(Key=(Key-B+Key-A), Msg=(R-B+R-A)) + + + + Host A Host B + ------ ------ + MP_JOIN -> + [B's token, A's nonce, + A's Address ID, flags] + <- MP_JOIN + [B's HMAC, B's nonce, + B's Address ID, flags] + ACK + MP_JOIN -> + [A's HMAC] + + <- ACK + + +Introduction + +* list the MPTCP connections in the pcap +* display some statistics on a specific MPTCP connection (list of subflows etc...); +* convert packet capture files (\*.pcap) to \*.csv files +* plot data sequence numbers for all subflows +* `XDG compliance `_, i.e., + |prog| looks for files in certain directories. will try to load your configuration from `$XDG_CONFIG_HOME/mptcpanalyzer/config` +* caching mechanism: mptcpanalyzer compares your pcap creation time and will + regenerate the cache if it exists in `$XDG_CACHE_HOME/mptcpanalyzer/` +* support 3rd party plugins (plots or commands) + +Most commands are self documented and/or with autocompletion. + +Then you have an interpreter with autocompletion that can generate & display plots such as the following: + +![Data Sequence Number (DSN) per subflow plot](examples/dsn.png) + +* How to use + +This package installs 2 programs: +- *mptcpanalyzer* to get details on a loaded pcap. + + +mptcpanalyzer can run into 3 modes: + 1. :ref:`interactive-mode` (default): an interpreter with some basic completion will accept your commands. + 2. :ref:`batch-mode` if a filename is passed as argument, it will load commands from this file. + 3. :ref:`oneshot`, it will consider the unknow arguments as one command, the same that could be used interactively + +For example, we can load an mptcp pcap (I made one available on `wireshark wiki +`_ or in this repository, in the _examples_ folder). + +It expects a trace to work with. If the trace has the form *XXX.pcap* extension, the script will look for its csv counterpart *XXX.pcap.csv*. The program will tell you what arguments are needed. Then you can open the generated graphs. + + + +-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Main where + +import MptcpAnalyzer.ArtificialFields +import MptcpAnalyzer.Cache +import MptcpAnalyzer.Commands +import MptcpAnalyzer.Commands.Definitions as CMD +import MptcpAnalyzer.Commands.Export as CLI +import MptcpAnalyzer.Commands.List as CLI +import MptcpAnalyzer.Commands.ListMptcp as CLI +import MptcpAnalyzer.Commands.Map as CLI +import qualified MptcpAnalyzer.Commands.Plot as Plots +import qualified MptcpAnalyzer.Commands.PlotOWD as Plots +import MptcpAnalyzer.Commands.Reinjections as CLI +import MptcpAnalyzer.Merge +import MptcpAnalyzer.Plots.Types +import MptcpAnalyzer.Stream +import MptcpAnalyzer.Types +-- import qualified MptcpAnalyzer.Plots.Owd as Plots +import qualified MptcpAnalyzer.Commands.Load as CL +-- import Control.Monad (void) +import MptcpAnalyzer.Pcap (defaultParserOptions) +import MptcpAnalyzer.Utils.Completion +import MptcpAnalyzer.Utils.Text +import Tshark.Interfaces +import Tshark.Live +import Tshark.Main + ( defaultTsharkOptions + , defaultTsharkPrefs + , genReadFilterFromTcpConnection + , generateCsvCommand + , tsharkReadFilter + ) +import Tshark.Sharkd + + +-- hackage +import Control.Lens ((^.)) +import qualified Data.Text as T +import Options.Applicative +import Options.Applicative.Common +import Options.Applicative.Help (parserHelp) +import Polysemy (Final, Members, Sem, runFinal) +import qualified Polysemy as P +import qualified Polysemy.Embed as P +import qualified Polysemy.IO as P +import qualified Polysemy.Internal as P +import Polysemy.Log (Log) +import qualified Polysemy.Log as Log +import Polysemy.Log.Colog (interpretLogStdout) +import qualified Polysemy.State as P +import Polysemy.Trace (trace) +import qualified Polysemy.Trace as P +import Prelude hiding (concat, init, log) +import System.Directory +import System.FilePath +-- import Colog.Actions +import Graphics.Rendering.Chart.Backend.Cairo + (FileFormat(..), FileOptions(..), renderableToFile, toFile) +import Graphics.Rendering.Chart.Renderable (toRenderable) +-- import Graphics.Rendering.Chart.Easy hiding (argument) +import qualified Data.Map as Map +import Graphics.Rendering.Chart.Layout (layout_title) + + +-- for noCompletion + -- <> Options.Applicative.value "/tmp" +-- import System.Posix.Signals -- installHandler +import Control.Lens (view, (^.)) +import Control.Monad.State.Lazy (State, StateT, execStateT, get, put) +import Data.Either (fromLeft) +import Data.Foldable (forM_) +import Data.Maybe (catMaybes, fromMaybe) +import Distribution.Compat.Internal.TempFile (openTempFile) +import Distribution.Simple.Utils (withTempFileEx) +import Frames (Frame, Record, recMaybe) +import Frames as F +import Frames.CSV (writeDSV) +import Frames.InCore (toFrame) +import MptcpAnalyzer.Loader +import Pipes hiding (Proxy) +import System.Console.ANSI +import System.Console.Haskeline +import System.Exit +import System.Process hiding (runCommand) +import Data.List (isPrefixOf) +import Debug.Trace (traceShowId) +import GHC.Conc (forkIO) +import GHC.IO.Handle +import Options.Applicative.Builder (allPositional) +import Options.Applicative.Types +import System.IO (stderr, stdout) +import Tshark.Fields (TsharkFieldDesc(tfieldFullname), baseFields) +import MptcpAnalyzer.Plots.Live + +data CLIArguments = CLIArguments { + _input :: Maybe FilePath + , version :: Bool -- ^ to show version + , cacheDir :: Maybe FilePath -- ^ Folder where to log files + , logLevel :: Log.Severity -- ^ what level to use to parse + , extraCommands :: [String] -- ^ commands to run on start + } + + +defaultImageOptions :: FileOptions +defaultImageOptions = FileOptions (800,600) PNG + +loggerName :: String +loggerName = "main" + +deriving instance Read Log.Severity + + -- <*> commandGroup "Loader commands" + -- <> command "load-csv" CL.piLoadCsv + +startupParser :: Parser CLIArguments +startupParser = CLIArguments + <$> optional ( strOption + ( long "load" + <> short 'l' + <> help "Either a pcap or a csv file (in good format).\ + \When a pcap is passed, mptcpanalyzer will look for a its cached csv.\ + \If it can't find one (or with the flag --regen), it will generate a \ + \csv from the pcap with the external tshark program." + <> metavar "INPUT_FILE" )) + <*> switch ( + long "version" + <> help "Show version" + ) + <*> optional ( strOption + ( long "cachedir" + <> help "mptcpanalyzer creates a cache of files in the folder \ + \$XDG_CACHE_HOME/mptcpanalyzer" + -- <> showDefault + -- <> Options.Applicative.value "/tmp" + <> metavar "CACHEDIR" )) + <*> option auto + ( long "log-level" + <> help "Log level" + <> showDefault + <> Options.Applicative.value Log.Info + <> metavar "LOG_LEVEL" ) + -- optional arguments + <*> many ( argument str ( + metavar "COMMANDS..." + )) + + +opts :: ParserInfo CLIArguments +opts = info (startupParser <**> helper) + ( fullDesc + <> progDesc "Tool to provide insight in MPTCP (Multipath Transmission Control Protocol)\ + \performance via the generation of stats & plots" + <> header "Type 'help' or '?' to list the available commands" + -- <> footer "You can report issues/contribute at https://github.com/teto/mptcpanalyzer" + ) + + +-- https://github.com/sdiehl/repline/issues/32 + +-- just for testing, to remove afterwards +defaultPcap :: FilePath +defaultPcap = "examples/client_2_filtered.pcapng" + + -- P.modify (\s -> s { _prompt = pcapFilename ++ "> ", + -- _loadedFile = Just frame + -- }) +finalizePrompt :: String -> String +finalizePrompt newPrompt = setSGRCode [SetColor Foreground Vivid Red] ++ newPrompt ++ "> " ++ setSGRCode [Reset] + +-- alternatively could modify defaultPrefs +-- subparserInline + multiSuffix helpShowGlobals +defaultParserPrefs :: ParserPrefs +defaultParserPrefs = (prefs $ showHelpOnEmpty <> showHelpOnError) + { + prefBacktrack = NoBacktrack + } + + +-- default if complete = completeFilename, +-- (String, String) -> m (String, [Completion]) +customCompleteFunc :: CompletionFunc IO +customCompleteFunc = completeFilename +-- customCompleteFunc _i = return ("toto", [ Completion "toInsert" "choice 1" False ]) + +-- debugParser :: ArgumentReachability -> Option x -> String +-- debugParser reachability opt = case optMain opt of +-- OptReader ns _ _ -> "optreader" +-- FlagReader ns _ -> "flagReader" +-- ArgReader rdr -> "argreader" +-- -- >>= \x -> return $ Completion x "argreader help" True +-- CmdReader _ ns p -> "cmdreader" + + +{- + +Dont display anything before the call to execParser otherwise it gets printed in +the different shell completion scripts +-} +main :: IO () +main = do + + cacheFolderXdg <- getXdgDirectory XdgCache "mptcpanalyzer2" + -- Create cache if doesn't exist + doesDirectoryExist cacheFolderXdg >>= \case + -- TODO log it instead + -- putStrLn ("cache folder already exists" ++ show cacheFolderXdg) + True -> return () + False -> createDirectory cacheFolderXdg + + let myState = MyState { + _stateCacheFolder = cacheFolderXdg + , _loadedFile = Nothing + , _prompt = finalizePrompt ">" + , _sharkdHandle = Nothing + } + + options <- execParser opts + + putStrLn "Commands:" + print $ extraCommands options + + let haskelineSettings = (Settings { + complete = generateHaskelineCompleterFromParserInfo defaultParserPrefs mainParserInfo + , historyFile = Just $ cacheFolderXdg "history" + , autoAddHistory = True + }) + let + cacheConfig :: CacheConfig + cacheConfig = CacheConfig { + cacheFolder = cacheFolderXdg + , cacheEnabled = True + } + + _ <- runInputT haskelineSettings $ + runFinal @(InputT IO) + $ P.embedToFinal . P.runEmbedded lift + $ P.traceToStdout + $ P.runState myState + $ runCache cacheConfig + $ interpretLogStdout + (inputLoop (extraCommands options)) + + + -- TODO when the process is not nothing + -- withProcessHandle (_sharkdHandle myState) $ \ph_ -> + -- case ph_ of + -- OpenHandle pid -> signalProcess sigKILL pid + -- ClosedHandle _ -> return () -- shouldn't happen + return () + + +-- TODO move + + +piListInterfaces :: ParserInfo CommandArgs +piListInterfaces = info (pure ArgsListInterfaces) + ( fullDesc + <> progDesc "List interfaces as seen by tshark" + <> footer "Example: load-pcap examples/client_2_filtered.pcapng" + <> forwardOptions + ) + +-- |Global parser: contains every available command +-- TODO for some commands we could factorize the preprocessing eg check a file +-- was pre-loaded +-- aka check the if loadedFile was loaded +-- one can create groups with <|> subparser +mainParser :: Parser CommandArgs +mainParser = subparser ( + commandGroup "Generic" + -- <> command "help" helpParser + <> command "quit" quit + -- <> commandGroup "Loader commands" + <> command "load-csv" CL.piLoadCsv + <> command "load-pcap" CL.piLoadPcapOpts + <> commandGroup "TCP commands" + <> command "tcp-summary" CLI.piTcpSummaryOpts + <> command "mptcp-summary" CLI.piMptcpSummaryOpts + <> command "list-tcp" CLI.piListTcpOpts + <> command "list-tcp-from-file" piListFromFile + <> command "map-tcp" CLI.mapTcpOpts + <> command "map-mptcp" CLI.mapMptcpOpts + <> commandGroup "MPTCP commands" + <> command "list-reinjections" CLI.piListReinjections + <> command "list-mptcp" CLI.piListMpTcpOpts + <> command "list-interfaces" piListInterfaces + <> command "export" CLI.piExportOpts + <> command "analyze" CLI.piQualifyReinjections + <> commandGroup "TCP plots" + -- TODO here we should pass a subparser + -- <> subparser ( + -- Main.piParserGeneric + <> command "plot-tcp" ( info Plots.parserPlotTcpMain (progDesc "Plot One-Way-Delays (also called One-Time-Trips)")) + <> command "plot-mptcp" ( info Plots.parserPlotMptcpMain (progDesc "Multipath-tcp plots")) + <> command "plot-tcp-live" ( info Plots.parserPlotTcpLive (progDesc "TCP Live plots")) + <> command "plot-mptcp-live" ( info Plots.parserPlotMptcpLive (progDesc "MPTCP Live plots")) + ) + where + helpParser = info (pure ArgsHelp) (progDesc "Display help") + quit = info (pure ArgsQuit) (progDesc "Quit mptcpanalyzer") + piListFromFile = info ( + ArgsTcpSummaryFromFile <$> + argument filenameReader (metavar "PCAP" + <> completer completePath + <> help "Load a Pcap file" + )) + ( fullDesc + <> progDesc "Load a pcap file via wireshark" + <> footer "Example: load-pcap examples/client_2_filtered.pcapng" + <> allPositional + ) + + + +-- |Main parser +mainParserInfo :: ParserInfo CommandArgs +-- mainParserInfo = info (mainParser <**> helper) +mainParserInfo = info mainParser + ( fullDesc + <> allPositional + <> progDesc "Tool to provide insight in MPTCP (Multipath Transmission Control Protocol)\ + \performance via the generation of stats & plots" + <> header "hello - a test for optparse-applicative" + <> footer "You can report issues/contribute at https://github.com/teto/mptcpanalyzer" + -- <> noIntersperse + -- <> forwardOptions + ) + + +cmdListInterfaces :: (Members '[ + Log, Cache, + P.Trace, P.State MyState, + P.Embed IO + ] r) => Sem r CMD.RetCode +cmdListInterfaces = do + (exitCode, ifs) <- P.embed listInterfaces + + trace "Listing interfaces:" + trace $ "ifs" ++ concatMap (\x -> x ++ "\n") ifs + return CMD.Continue + + +runCommand :: (Members '[Log, Cache, P.Trace, P.State MyState, P.Embed IO] r) + => CommandArgs -> Sem r CMD.RetCode + +runCommand (ArgsLoadPcap fileToLoad) = loadPcap fileToLoad + -- ret <- CL.loadPcap fileToLoad + -- TODO modify only on success + -- P.modify (\s -> s { _prompt = pcapFilename ++ "> ", + -- _loadedFile = Just frame + -- }) + -- return ret +runCommand (ArgsLoadCsv csvFile _) = CL.cmdLoadCsv csvFile +runCommand (ArgsTcpSummary detailed streamId) = CLI.cmdTcpSummary streamId detailed +runCommand (ArgsTcpSummaryFromFile filepath ) = CLI.cmdTcpSummarySharkd filepath (StreamId 0) False +runCommand (ArgsMptcpSummary detailed streamId) = CLI.cmdMptcpSummary streamId detailed +runCommand (ArgsListSubflows detailed) = CLI.cmdListSubflows detailed +runCommand (ArgsListReinjections streamId) = CLI.cmdListReinjections streamId +runCommand (ArgsListTcpConnections detailed) = CLI.cmdListTcpConnections detailed +runCommand (ArgsListMpTcpConnections detailed) = CLI.cmdListMptcpConnections detailed +runCommand ArgsListInterfaces = cmdListInterfaces +runCommand (ArgsExport out) = CLI.cmdExport out +runCommand (ArgsPlotGeneric plotSettings plotArgs) = runPlotCommand plotSettings plotArgs +runCommand (ArgsMapTcpConnections cmd False) = CLI.cmdMapTcpConnection cmd +runCommand (ArgsMapTcpConnections args True) = CLI.cmdMapMptcpConnection args +runCommand (ArgsQualifyReinjections mapping verbose) = CLI.cmdQualifyReinjections mapping [RoleServer] verbose +runCommand ArgsQuit = cmdQuit +runCommand ArgsHelp = cmdHelp + +-- TODO move commands to their own module +-- TODO it should update the loadedFile in State ! +loadPcap :: (Members '[Log, P.State MyState, Cache, P.Embed IO] r) + => FilePath -- ^ File to load + -> Sem r RetCode +loadPcap pcapFilename = do + Log.info $ "loading pcap " <> tshow pcapFilename + mFrame <- loadPcapIntoFrame defaultTsharkPrefs pcapFilename + -- fmap onSuccess mFrame + case mFrame of + Left _ -> return CMD.Continue + Right frame -> do + P.modify (\s -> s { + _prompt = finalizePrompt pcapFilename, + _loadedFile = Just frame + }) + Log.info "Frame loaded" >> return CMD.Continue + +-- | Quits the program +cmdQuit :: Members '[P.Trace] r => Sem r CMD.RetCode +cmdQuit = trace "Thanks for flying with mptcpanalyzer" >> return CMD.Exit + +-- | Prints the help when requested +cmdHelp :: Members '[P.Trace, P.State MyState] r => Sem r CMD.RetCode +cmdHelp = do + -- TODO display help / use trace instead + trace $ show $ parserHelp defaultParserPrefs mainParser + return CMD.Continue + +-- |Command specific to plots +-- TODO these should return a plot instead of a generated file so that one can overwrite the title +-- also this should be moved somewhere else +runPlotCommand :: (Members '[Log, Cache, P.Trace, P.State MyState, P.Embed IO] r) + => PlotSettings -> ArgsPlots + -> Sem r CMD.RetCode +runPlotCommand (PlotSettings mbOut _mbTitle displayPlot mptcpPlot) specificArgs = do + (tempPath, handle) <- P.embed $ openTempFile "/tmp" "plot.png" + _ <- case specificArgs of + (ArgsPlotTcpAttr pcapFilename streamId attr mbDest) -> do + let destinations = getDests mbDest + Log.debug $ "MPTCP plot" <> tshow mptcpPlot + + res <- if mptcpPlot then do + eFrame <- buildAFrameFromStreamIdMptcp defaultTsharkPrefs pcapFilename (StreamId streamId) + case eFrame of + Left err -> return $ CMD.Error err + Right frame -> Plots.cmdPlotMptcpAttribute attr tempPath destinations frame + + else do + eFrame <- buildAFrameFromStreamIdTcp defaultTsharkPrefs pcapFilename (StreamId streamId) + case eFrame of + Left err -> return $ CMD.Error err + Right frame -> do + l <- Plots.cmdPlotTcpAttribute attr destinations frame + -- toRenderable + P.embed $ toFile defaultImageOptions tempPath l + -- embed $ void $ renderableToFile defaultImageOptions tempPath (toRenderable l) + -- layout_title .= "TCP " ++ attr + -- l + return CMD.Continue + return res + + -- Destinations + (ArgsPlotOwdTcp mapping dest) -> + -- Log.info $ "plotting owd for tcp.stream " <> tshow streamId1 <> " and " <> tshow streamId2 + Plots.cmdPlotTcpOwd tempPath handle (getDests dest) mapping + + (ArgsPlotOwdMptcp (PcapMapping pcap1 streamId1 pcap2 streamId2) dest) -> do + Log.info "plotting mptcp owd" + eframe1 <- buildAFrameFromStreamIdMptcp defaultTsharkPrefs pcap1 streamId1 + eframe2 <- buildAFrameFromStreamIdMptcp defaultTsharkPrefs pcap2 streamId2 + + case (eframe1, eframe2 ) of + (Right aframe1, Right aframe2) -> do + mergedRes <- mergeMptcpConnectionsFromKnownStreams aframe1 aframe2 + -- let mbRecs = map recMaybe mergedRes + -- let justRecs = catMaybes mbRecs + -- Plots.cmdPlotMptcpOwd tempPath handle (getDests dest) (ffCon aframe1) mergedRes + error "not implemented" + (Left err, _) -> return $ CMD.Error err + (_, Left err) -> return $ CMD.Error err + + -- Starts livestatistics on a connection + ArgsPlotLiveTcp livePlotSettings -> + configureLivePlotTcp livePlotSettings >> return CMD.Continue + + ArgsPlotLiveMptcp livePlotSettings -> do + Log.info $ "Looking at destination " + configureLivePlotMptcp livePlotSettings >> return CMD.Continue + + P.embed $ forM_ mbOut (renameFile tempPath) + -- _ <- P.embed $ case mbOut of + -- -- user specified a file move the file + -- Just outFilename -> renameFile tempPath outFilename + -- Nothing -> return () + if displayPlot then do + let + createProc :: CreateProcess + -- for some reason it recognizes the image as application/octet-stream + -- and I can't manage to make it use my image/png application + createProc = (proc "xdg-open" [ tempPath ]) { + -- createProc = (proc "sxiv" [ tempPath ]) { + delegate_ctlc = True + } + + Log.info $ "Launching " <> tshow createProc + (_, _, mbHerr, ph) <- P.embed $ createProcess createProc + exitCode <- P.embed $ waitForProcess ph + return Continue + + else + return Continue + where + getDests mbDest = maybe [RoleClient, RoleServer] (: []) mbDest + + + +-- TODO use genericRunCommand +runIteration :: (Members '[Log, Cache, P.Trace, P.State MyState, P.Embed IO] r) + => Maybe String + -> Sem r CMD.RetCode +runIteration fullCmd = do + cmdCode <- case fmap Prelude.words fullCmd of + Nothing -> do + trace "please enter a valid command, see help" + return CMD.Continue + Just args -> do + -- TODO parse + Log.info $ "Running " <> tshow args + let parserResult = execParserPure defaultParserPrefs mainParserInfo args + case parserResult of + -- Failure (ParserFailure ParserHelp) + (Failure failure) -> do + -- last arg is progname + let (h, exit) = renderFailure failure "" + -- Log.debug h + P.trace h + Log.debug $ "Exit code " <> tshow exit + Log.debug $ "Passed args " <> tshow args + return $ case exit of + ExitSuccess -> CMD.Continue + ExitFailure _exitCode -> CMD.Error $ "could not parse: " ++ show failure + (CompletionInvoked _compl) -> return CMD.Continue + (Success parsedArgs) -> runCommand parsedArgs + + case cmdCode of + CMD.Exit -> P.trace "Exiting" >> return CMD.Exit + CMD.Error msg -> do + P.trace $ "CmdCode: Last command failed with message:\n" ++ show msg + return $ CMD.Error msg + behavior -> return behavior + +-- | Main loop of the program, will run commands in turn +inputLoop :: (Members '[Log , Cache, P.Trace, P.State MyState, P.Embed IO, P.Final (InputT IO)] r) + => [String] -> Sem r () +inputLoop = go + where + go :: (Members '[Log, Cache, P.Trace, P.State MyState, P.Embed IO, P.Final (InputT IO)] r) + => [String] -> Sem r () + go (xs:rest) = runIteration (Just xs) >>= \case + CMD.Exit -> trace "Exiting" + _ -> do + inputLoop rest + go [] = do + s <- P.get + minput <- P.embedFinal $ getInputLine (view prompt s) + runIteration minput >>= \case + CMD.Exit -> trace "Exiting" + -- _ -> pure () + _ -> inputLoop [] + diff --git a/tests/MptcpAnalyzer/LoaderSpec.hs b/tests/MptcpAnalyzer/LoaderSpec.hs new file mode 100644 --- /dev/null +++ b/tests/MptcpAnalyzer/LoaderSpec.hs @@ -0,0 +1,27 @@ +module MptcpAnalyzer.LoaderSpec ( +spec +) where +-- import Test.Tasty +-- import Test.Tasty.HUnit +import Data.Maybe (fromJust) +import Distribution.Simple.Utils (TempFileOptions(..), withTempFileEx) +import MptcpAnalyzer.ArtificialFields +import MptcpAnalyzer.Pcap +import MptcpAnalyzer.Stream +import Net.IP +import Net.IPv4 (localhost) +import Net.Tcp.Connection +import System.Exit (ExitCode(ExitSuccess)) +import System.IO +import Test.Hspec +import Test.QuickCheck hiding (Success) +import Tshark.Main + + + +-- TODO test (nombre de paquets par exemple ?) +-- buildAFrameFromStreamIdTcp +spec :: Spec +spec = describe "Checking pcap loader" $ do + it "test" $ + pendingWith "test" diff --git a/tests/MptcpAnalyzer/MapSpec.hs b/tests/MptcpAnalyzer/MapSpec.hs new file mode 100644 --- /dev/null +++ b/tests/MptcpAnalyzer/MapSpec.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module MptcpAnalyzer.MapSpec ( +spec +) where +-- import Test.Tasty +-- import Test.Tasty.HUnit +import Data.Maybe (fromJust) +import Distribution.Simple.Utils (TempFileOptions(..), withTempFileEx) +import Net.IP +import Net.IPv4 (localhost) +import Net.Tcp.Connection +import Polysemy (Final, Members, Sem, runFinal) +import qualified Polysemy as P +import qualified Polysemy.Embed as P +import qualified Polysemy.IO as P +import qualified Polysemy.Internal as P +import Polysemy.Log (Log) +import qualified Polysemy.Log as Log +import Polysemy.Log.Colog (interpretLogStdout) +import System.Exit (ExitCode(ExitSuccess)) +import System.IO +import Test.Hspec +import Test.QuickCheck hiding (Success) +import Tshark.Main + +import Data.Either (fromRight) +import Frames.Frame (Frame) +import MptcpAnalyzer.ArtificialFields +import MptcpAnalyzer.Cache +import MptcpAnalyzer.Loader (loadPcapIntoFrame) +import MptcpAnalyzer.Map +import MptcpAnalyzer.Pcap +import MptcpAnalyzer.Stream +import MptcpAnalyzer.Types +import Utils + +cacheConfig :: CacheConfig +cacheConfig = CacheConfig { + cacheFolder = "/tmp" + , cacheEnabled = False +} + + +loadTestFrames :: IO (FrameFiltered TcpConnection Packet, Frame Packet) +loadTestFrames = do + + aframes <- P.runM + $ interpretLogStdout + $ runCache cacheConfig + runTests + return aframes + + +runTests :: (Members '[P.Embed IO, Log, Cache] r) => Sem r (FrameFiltered TcpConnection Packet, Frame Packet) +runTests = do + -- :: Either String (Frame Packet) + eFrame1 <- loadPcapIntoFrame defaultTsharkPrefs "examples/client_2_cleaned.pcapng" + eFrame2 <- loadPcapIntoFrame defaultTsharkPrefs "examples/server_2_cleaned.pcapng" + + frame2 <- case eFrame2 of + Left err -> error err + Right frame -> return frame + + (aframe :: FrameFiltered TcpConnection Packet) <- case buildFrameFromStreamId (fromRight (error "should not happen") eFrame1) (StreamId 0) of + Left err -> error err + Right aframe -> return aframe + + return (aframe, frame2) + +-- TODO this should be part of a golden test with tasty instead +expectedMappings = [ + (TcpConnection {conTcpClientIp = ipv4 10 0 0 1, conTcpServerIp = ipv4 10 0 0 2, conTcpClientPort = 33782, conTcpServerPort = 5201, conTcpStreamId = StreamId 0},40) + ,(TcpConnection {conTcpClientIp = ipv4 10 0 0 1, conTcpServerIp = ipv4 10 0 0 2, conTcpClientPort = 33784, conTcpServerPort = 5201, conTcpStreamId = StreamId 1},30) + ,(TcpConnection {conTcpClientIp = ipv4 10 0 0 1, conTcpServerIp = ipv4 11 0 0 2, conTcpClientPort = 54595, conTcpServerPort = 5201, conTcpStreamId = StreamId 2},20) + ,(TcpConnection {conTcpClientIp = ipv4 10 0 0 1, conTcpServerIp = ipv4 11 0 0 2, conTcpClientPort = 57491, conTcpServerPort = 5201, conTcpStreamId = StreamId 3},20) + ,(TcpConnection {conTcpClientIp = ipv4 11 0 0 1, conTcpServerIp = ipv4 10 0 0 2, conTcpClientPort = 35589, conTcpServerPort = 5201, conTcpStreamId = StreamId 6},20) + ,(TcpConnection {conTcpClientIp = ipv4 11 0 0 1, conTcpServerIp = ipv4 10 0 0 2, conTcpClientPort = 50007, conTcpServerPort = 5201, conTcpStreamId = StreamId 7},20) + ,(TcpConnection {conTcpClientIp = ipv4 11 0 0 1, conTcpServerIp = ipv4 11 0 0 2, conTcpClientPort = 50077, conTcpServerPort = 5201, conTcpStreamId = StreamId 5},10)] + +spec :: Spec +spec = describe "Checking connection mapper" $ do + before loadTestFrames $ it "test" $ \(aframe, frame1) -> + mapTcpConnection aframe frame1 `shouldBe` expectedMappings + -- pendingWith "test" + -- TODO check + -- mapTcpConnection + diff --git a/tests/MptcpAnalyzer/PcapSpec.hs b/tests/MptcpAnalyzer/PcapSpec.hs new file mode 100644 --- /dev/null +++ b/tests/MptcpAnalyzer/PcapSpec.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} +module MptcpAnalyzer.PcapSpec ( +spec +) where +import MptcpAnalyzer.Pcap +import MptcpAnalyzer.Stream +import Net.IP +import Net.IPv4 (localhost) +import Net.Tcp.Connection +import Test.Hspec +import Data.Maybe (fromJust) +import MptcpAnalyzer.ArtificialFields +import Utils +import qualified Data.Foldable as F +import MptcpAnalyzer.Types +import Distribution.Compat.Lens (view) +-- import Control.Lens + + +exampleTcpConnectionLocalhost :: TcpConnection +exampleTcpConnectionLocalhost = TcpConnection (fromIPv4 localhost) (fromIPv4 localhost) 24 42 (StreamId 0) + +exampleTcpConnection0 :: TcpConnection +exampleTcpConnection0 = TcpConnection (fromJust $ decode "10.0.0.1") (fromJust $ decode "192.10.0.2") 24 42 (StreamId 1) + + +-- addTcpDestinationsToAFrame +-- genTcpDestFrame + +spec :: Spec +spec = describe "absolute" $ do + it "Check TcpConnection score" $ + scoreTcpCon exampleTcpConnectionLocalhost exampleTcpConnection0 < scoreTcpCon exampleTcpConnectionLocalhost exampleTcpConnectionLocalhost + before (loadAFrame "examples/client_2_cleaned.pcapng" (StreamId 0)) $ it "Check that destinations are set correctly" $ \aframe -> + length (genTcpDestFrameFromAFrame aframe) == (length $ ffFrame aframe) + before (loadAFrame "examples/client_2_cleaned.pcapng" (StreamId 0)) $ it "Check that destinations are set correctly" $ \aframe -> + let + tcpdestFrame = genTcpDestFrameFromAFrame aframe + tcpDests = F.toList $ view tcpDest <$> tcpdestFrame + -- clientFrame = filterFrame (\x -> x ^. tcpDest == RoleClient) tcpdestFrame + in + length (filter ((==) RoleServer) tcpDests) `shouldBe` 16 + -- length (ffFrame aframe) `shouldBe` (length $ clientFrame) + -- it "Generate the correct tshark filter" $ +-- genReadFilterFromTcpConnection exampleTcpConnection0 (Just RoleClient) +-- `shouldBe` "tcp and ip.addr==127.0.0.1 and ip.addr==127.0.0.1 and tcp.srcport==42 and tcp.dstport==24" +-- -- exportToCsv "mptcpanalyzer/examples/client_2_filtered.pcapng" +-- it "Tshark generates a proper CSV file" $ do +-- -- cant find the profile so there is some herr being written +-- withFile "/tmp/mptcp.csv" ReadWriteMode (exportToCsv defaultTsharkPrefs "examples/client_2_filtered.pcapng") >>= \x -> fst x `shouldBe` ( ExitSuccess) +-- -- `shouldThrow` +-- it "Test frame loading" $ +-- pendingWith "test" diff --git a/tests/Net/Tcp/StatsSpec.hs b/tests/Net/Tcp/StatsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Net/Tcp/StatsSpec.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{- +Module: StatsSpec +Description : Description +Maintainer : matt +Portability : Linux + +Load a pcap in chunks and check that it produces the same result +-} +module Net.Tcp.StatsSpec ( + spec +) where +import Frames.Exploration +-- import MptcpAnalyzer.Loader +import MptcpAnalyzer.Pcap +import Test.Hspec +-- import Test.QuickCheck hiding (Success) + +-- import Data.Either (fromRight) +-- import Frames +import MptcpAnalyzer.ArtificialFields +-- import MptcpAnalyzer.Cache +-- import MptcpAnalyzer.Stream +import MptcpAnalyzer.Types +import Net.Tcp +import Net.Tcp.Stats +-- import Polysemy (Final, Members, Sem, runFinal) +-- import qualified Polysemy as P +-- import qualified Polysemy.Embed as P +-- import qualified Polysemy.IO as P +-- import qualified Polysemy.Internal as P +-- import Polysemy.Log (Log) +-- import qualified Polysemy.Log as Log +-- import Polysemy.Log.Colog (interpretLogStdout) +-- import qualified Polysemy.State as P +-- import qualified Polysemy.Trace as P +-- import Tshark.Main (defaultTsharkPrefs) +import Utils +import Data.Foldable (foldl') +import Net.Stream + +-- cacheConfig :: CacheConfig +-- cacheConfig = CacheConfig { +-- cacheFolder = "/tmp" +-- , cacheEnabled = False +-- } + +expectedForwardStats, expectedForwardStats0, expectedForwardStats1 :: TcpUnidirectionalStats +expectedBackwardStats, expectedBackwardStats0, expectedForwardStatsTotal01 :: TcpUnidirectionalStats +expectedForwardStats = mempty +expectedBackwardStats = mempty +expectedForwardStats0 = TcpUnidirectionalStats {tusNrPackets = 16, tusStartTime = 0.0, tusEndTime = 45.831181697, tusMinSeq = 0, tusSndUna = 457, tusSndNext = 457, tusReinjectedBytes = 0} +expectedForwardStats1 = mempty +expectedBackwardStats0 = TcpUnidirectionalStats {tusNrPackets = 13, tusStartTime = 0.184116349, tusEndTime = 45.842675096, tusMinSeq = 0, tusSndUna = 309, tusSndNext = 309, tusReinjectedBytes = 0} +expectedForwardStatsTotal01 = mempty + +-- TcpUnidirectionalStats { +-- tusStartPacketId = 0 -- (frameRow frame 0) ^. packetId +-- , tusEndPacketId = 0 -- (frameRow frame (frameLength frame - 1)) ^. packetId +-- , tusNrPackets = frameLength frame +-- , tusStartTime = minTime +-- , tusEndTime = maxTime +-- -- TODO fill it +-- , tusMinSeq = minSeq + +-- -- TODO should be max of seen acks +-- , tusSndUna = maxSeqRow ^. tcpSeq + fromIntegral ( maxSeqRow ^. tcpLen) :: Word32 +-- , tusSndNext = maxSeqRow ^. tcpSeq + fromIntegral ( maxSeqRow ^. tcpLen ) :: Word32 +-- , tusReinjectedBytes = 0 +-- } + +-- loadAFrame :: IO (FrameFiltered TcpConnection Packet) +-- loadAFrame = do + +-- aframe <- P.runM +-- $ interpretLogStdout +-- $ runCache cacheConfig +-- runTests +-- return aframe +-- putStrLn "finished" + + + + +-- runTests :: (Members '[P.Embed IO, Log , Cache] r) => Sem r (FrameFiltered TcpConnection Packet) +-- runTests = do +-- -- :: Either String (Frame Packet) +-- frame1 <- loadPcapIntoFrame defaultTsharkPrefs "examples/client_2_cleaned.pcapng" + +-- (aframe :: FrameFiltered TcpConnection Packet) <- case buildFrameFromStreamId (fromRight (error "should not happen") frame1) (StreamId 0) of +-- Left err -> error err +-- Right aframe -> return aframe + +-- return aframe + + -- TODO run hspec and check FrameLength is the same ? + -- check stats over the whole file + -- P.embed $ hspec $ + + +expectedStats :: TcpUnidirectionalStats +-- expectedStats = mempty +expectedStats = TcpUnidirectionalStats {tusNrPackets = 13, tusStartTime = 0.0, tusEndTime = 45.842675096, tusMinSeq = 0, tusSndUna = 0, tusSndNext = 0, tusReinjectedBytes = 0} + +splitAFrame :: FrameFiltered TcpConnection Packet -> Int -> [FrameFiltered TcpConnection Packet] +splitAFrame aframe chunkSize = + -- takeRows / dropRow + go aframe [] + where + go aframe' acc = if aframeLength aframe' < chunkSize then + acc ++ [aframe'] + else + go (FrameTcp (ffCon aframe') (dropRows chunkSize $ ffFrame aframe')) + acc ++ [(FrameTcp (ffCon aframe') (takeRows chunkSize $ ffFrame aframe'))] + + + +-- beforeWith (loadAFrame) $ +-- before loadAFrame $ describ +spec :: Spec +spec = before (loadAFrame "examples/client_2_cleaned.pcapng" (StreamId 0)) $ + describe "Checking stats" $ do + it "Check generated forward stats" $ \aframe -> + getTcpStatsFromAFrame (addTcpDestinationsToAFrame aframe) RoleServer `shouldBe` expectedForwardStats0 + it "Check generated backwards stats" $ \aframe -> + getTcpStatsFromAFrame (addTcpDestinationsToAFrame aframe) RoleClient `shouldBe` expectedBackwardStats0 + + it "Processing stats in chunks equal processing the full batch" $ \aframe -> let + chunks = splitAFrame aframe 2 + in + foldl' (\origStats newAframe -> origStats <> getTcpStatsFromAFrame (addTcpDestinationsToAFrame newAframe) RoleClient ) mempty chunks `shouldBe` expectedStats + + -- it "Checking two crafted stats" $ \aframe -> let + + -- it "Test append of stats" $ + -- expectedForwardStats0head <> expectedForwardStats0tail `shouldBe` expectedForwardStats0 + -- pendingWith "test" + diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +-- https://hspec.github.io/hspec-discover.html +import qualified Spec +import Test.Hspec.Formatters +import Test.Hspec.Runner + +main :: IO () +main = hspecWith defaultConfig {configFormatter = Just progress} Spec.spec diff --git a/tests/Tshark/MainSpec.hs b/tests/Tshark/MainSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Tshark/MainSpec.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +module Tshark.MainSpec (spec) +where +import Data.Maybe (fromJust) +import Distribution.Simple.Utils (TempFileOptions(..), withTempFileEx) +import MptcpAnalyzer.ArtificialFields +import MptcpAnalyzer.Pcap +import MptcpAnalyzer.Stream +import Net.IP +import Net.IPv4 (localhost) +import Net.Tcp.Connection +import System.Exit (ExitCode(ExitSuccess)) +import System.IO +import Test.Hspec +import Test.QuickCheck hiding (Success) +import Tshark.Main + + + +exampleTcpConnectionLocalhost :: TcpConnection +exampleTcpConnectionLocalhost = TcpConnection (fromIPv4 localhost) (fromIPv4 localhost) 24 42 (StreamId 0) + +exampleTcpConnection0 :: TcpConnection +exampleTcpConnection0 = TcpConnection (fromJust $ decode "10.0.0.1") (fromJust $ decode "192.10.0.2") 24 42 (StreamId 1) + +opts :: TempFileOptions +opts = TempFileOptions True + +-- main :: IO () +-- main = hspec $ do +spec :: Spec +spec = + describe "tshark tests" $ do + it "Generate bidirectional tshark filter" $ + genReadFilterFromTcpConnection exampleTcpConnectionLocalhost Nothing + `shouldBe` "tcp and ip.addr==127.0.0.1 and ip.addr==127.0.0.1 and tcp.port==42 and tcp.port==24" + it "Check the unidirectional filter" $ + genReadFilterFromTcpConnection exampleTcpConnection0 (Just RoleClient) + `shouldBe` "tcp and ip.src==10.0.0.1 and ip.dst==192.10.0.2 and tcp.srcport==24 and tcp.dstport==42" + -- exportToCsv "mptcpanalyzer/examples/client_2_filtered.pcapng" + it "Tshark generates a proper CSV file" $ do + -- cant find the profile so there is some herr being written + withFile "/tmp/mptcp.csv" ReadWriteMode (exportToCsv defaultTsharkPrefs "examples/client_2_filtered.pcapng") >>= \x -> fst x `shouldBe` ( ExitSuccess) + + -- `shouldThrow` + it "Test frame loading" $ + pendingWith "test" + diff --git a/tests/Utils.hs b/tests/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/Utils.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Utils ( + loadAFrame + -- , loadPcapIntoFrameNoCache +) +where + +import MptcpAnalyzer.ArtificialFields +import MptcpAnalyzer.Pcap +import MptcpAnalyzer.Stream +import MptcpAnalyzer.Types +import qualified MptcpAnalyzer.Utils.Text as T +import Net.Tcp.Connection +import Tshark.Main + +import Control.Monad.IO.Class (liftIO) +import Data.Either (fromRight) +import Distribution.Simple.Utils +import Frames (ColumnHeaders, ElField, FrameRec) +import qualified Frames.CSV +import qualified Frames.InCore +import MptcpAnalyzer.Cache (CacheConfig(..)) +import MptcpAnalyzer.Loader (loadPcapIntoFrame, loadPcapIntoFrameNoCache) +import Polysemy (Final, Members, Sem, runFinal) +import qualified Polysemy as P +import qualified Polysemy.Embed as P +import qualified Polysemy.IO as P +import qualified Polysemy.Internal as P +import Polysemy.Log (Log) +import qualified Polysemy.Log as Log +import Polysemy.Log.Colog (interpretLogStdout) +import System.Exit +cacheDisabledConfig :: CacheConfig +cacheDisabledConfig = CacheConfig { + cacheFolder = "/tmp" + , cacheEnabled = False +} + +-- loadAFrame :: IO (FrameFiltered TcpConnection Packet) +-- loadAFrame = do + +-- aframe <- P.runM +-- $ interpretLogStdout +-- $ runCache cacheDisabledConfig +-- runTests +-- return aframe +-- putStrLn "finished" + +-- loadAFrame +-- (aframe :: FrameFiltered TcpConnection Packet) <- case buildFrameFromStreamId (fromRight (error "should not happen") eFrame1) (StreamId 0) of +-- Left err -> error err +-- Right aframe -> return aframe + + +loadAFrame :: FilePath -> StreamId Tcp -> IO (FrameFiltered TcpConnection Packet) +loadAFrame = loadAFrameWithOpts defaultTsharkPrefs + +loadAFrameWithOpts :: TsharkParams -> FilePath -> StreamId Tcp -> IO (FrameFiltered TcpConnection Packet) +loadAFrameWithOpts tsharkParams path streamId = do + frame1 <- loadPcapIntoFrameNoCache tsharkParams path + + (aframe :: FrameFiltered TcpConnection Packet) <- case buildFrameFromStreamId (fromRight (error "should not happen") frame1) streamId of + Left err -> error err + Right aframe -> return aframe + + return aframe + +-- runTests :: (Members '[P.Embed IO, Log, Cache] r) => Sem r (FrameFiltered TcpConnection Packet) +-- runTests = do +-- -- :: Either String (Frame Packet) +-- frame1 <- loadPcapIntoFrame defaultTsharkPrefs "examples/client_2_cleaned.pcapng" + +-- (aframe :: FrameFiltered TcpConnection Packet) <- case buildFrameFromStreamId (fromRight (error "should not happen") frame1) (StreamId 0) of +-- Left err -> error err +-- Right aframe -> return aframe + +-- return aframe + diff --git a/tests/integration/list-tcp.test b/tests/integration/list-tcp.test new file mode 100644 --- /dev/null +++ b/tests/integration/list-tcp.test @@ -0,0 +1,24 @@ +cabal run mptcpanalyzer "load-pcap examples/client_2_filtered.pcapng" "quit" +<<< +>>> +Up to date +cache folder already exists"/home/teto/.cache/mptcpanalyzer2" +Commands +["load-pcap examples/client_2_filtered.pcapng","quit"] +loading pcap examples/client_2_filtered.pcapng +Start loading pcap examples/client_2_filtered.pcapng +getCache error: Not implemented yet +Calling tshark + +loading pcap examples/client_2_filtered.pcapng +Start loading pcap examples/client_2_filtered.pcapng +getCache error: Not implemented yet +Calling tshark +Exporting fields ["frame.number","frame.interface_name","frame.time_epoch","frame.time_relative","_ws.col.ipsrc","_ws.col.ipdst","ip.src_host","ip.dst_host","tcp.stream","tcp.srcport","tcp.dstport","tcp.window_size","tcp.flags","tcp.option_kind","tcp.seq","tcp.len","tcp.ack","tcp.options.timestamp.tsval","tcp.options.timestamp.tsecr","mptcp.expected_token","mptcp.stream","tcp.options.mptcp.sendkey","tcp.options.mptcp.recvkey","tcp.options.mptcp.recvtok","tcp.options.mptcp.datafin.flag","tcp.options.mptcp.version","mptcp.ack","mptcp.dsn"] +Command run: RawCommand "tshark" ["-r","examples/client_2_filtered.pcapng","-E","separator=|","-o","mptcp.analyze_mptcp:true","-o","mptcp.intersubflows_retransmission:true","-o","mptcp.relative_sequence_numbers:true","-o","mptcp.analyze_mappings:true","-o","tcp.analyze_sequence_numbers:true","-o","gui.column.format:Time,%At,ipsrc,%s,ipdst,%d","-2","-R","mptcp or tcp and not icmp","-T","fields","-e","frame.number","-e","frame.interface_name","-e","frame.time_epoch","-e","frame.time_relative","-e","_ws.col.ipsrc","-e","_ws.col.ipdst","-e","ip.src_host","-e","ip.dst_host","-e","tcp.stream","-e","tcp.srcport","-e","tcp.dstport","-e","tcp.window_size","-e","tcp.flags","-e","tcp.option_kind","-e","tcp.seq","-e","tcp.len","-e","tcp.ack","-e","tcp.options.timestamp.tsval","-e","tcp.options.timestamp.tsecr","-e","mptcp.expected_token","-e","mptcp.stream","-e","tcp.options.mptcp.sendkey","-e","tcp.options.mptcp.recvkey","-e","tcp.options.mptcp.recvtok","-e","tcp.options.mptcp.datafin.flag","-e","tcp.options.mptcp.version","-e","mptcp.ack","-e","mptcp.dsn"] +exported to file /tmp/mptcp31108-0.csv +Number of rows after loading 4164 +Saved into cache +Frame loaded +>>>2 +>>>= 0