From 6f548918efe7d4d3f8f9d9b04c58eac37d4e462d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?TG=20=C3=97=20=CE=98?= <*@tg-x.net> Date: Sun, 27 Oct 2019 22:49:12 +0100 Subject: [PATCH] cycylon, vicinity, ringcast, poldercast --- .gitignore | 5 + LICENSE.md | 660 ++++++++++++++++++ Makefile | 15 + README.md | 56 ++ dune-project | 2 + lib/p2p-cyclon-lwt/dune | 5 + lib/p2p-cyclon-lwt/p2p_cyclon_lwt.ml | 141 ++++ lib/p2p-cyclon-lwt/s.ml | 86 +++ lib/p2p-cyclon/dune | 4 + lib/p2p-cyclon/p2p_cyclon.ml | 75 ++ lib/p2p-cyclon/p2p_cyclon.mli | 54 ++ lib/p2p-poldercast-lwt/dune | 14 + lib/p2p-poldercast-lwt/p2p_poldercast_lwt.ml | 164 +++++ lib/p2p-poldercast-lwt/s.ml | 74 ++ lib/p2p-poldercast/dune | 4 + lib/p2p-poldercast/node.ml | 72 ++ lib/p2p-poldercast/p2p-poldercast | 16 + lib/p2p-poldercast/p2p_poldercast.ml | 154 ++++ lib/p2p-poldercast/s.ml | 74 ++ lib/p2p-ringcast-lwt/dune | 5 + lib/p2p-ringcast-lwt/p2p_ringcast_lwt.ml | 166 +++++ lib/p2p-ringcast-lwt/s.ml | 102 +++ lib/p2p-ringcast/dune | 4 + lib/p2p-ringcast/p2p_ringcast.ml | 213 ++++++ lib/p2p-ringcast/s.ml | 53 ++ lib/p2p-vicinity-lwt/dune | 5 + lib/p2p-vicinity-lwt/p2p_vicinity_lwt.ml | 143 ++++ lib/p2p-vicinity-lwt/s.ml | 89 +++ lib/p2p-vicinity/dune | 4 + lib/p2p-vicinity/p2p_vicinity.ml | 100 +++ lib/p2p-vicinity/s.ml | 24 + lib/p2p/dune | 4 + lib/p2p/group.ml | 37 + lib/p2p/group_id.ml | 17 + lib/p2p/msg_id.ml | 17 + lib/p2p/node.ml | 68 ++ lib/p2p/node_id.ml | 57 ++ lib/p2p/s.ml | 399 +++++++++++ lib/p2p/view.ml | 157 +++++ p2p-cyclon-lwt.opam | 27 + p2p-cyclon.opam | 23 + p2p-poldercast-lwt.opam | 26 + p2p-poldercast.opam | 24 + p2p-ringcast-lwt.opam | 26 + p2p-ringcast.opam | 25 + p2p-vicinity-lwt.opam | 26 + p2p-vicinity.opam | 23 + p2p.opam | 27 + test/p2p-cyclon-lwt/dune | 15 + test/p2p-cyclon-lwt/test_cyclon_lwt.ml | 146 ++++ test/p2p-cyclon/dune | 9 + test/p2p-cyclon/test_cyclon.ml | 80 +++ test/p2p-poldercast-lwt/dune | 16 + .../p2p-poldercast-lwt/test_poldercast_lwt.ml | 202 ++++++ test/p2p-poldercast/dune | 11 + test/p2p-poldercast/test_poldercast.ml | 80 +++ test/p2p-ringcast-lwt/dune | 14 + test/p2p-ringcast-lwt/test_ringcast_lwt.ml | 182 +++++ test/p2p-ringcast/dune | 9 + test/p2p-ringcast/test_ringcast.ml | 96 +++ test/p2p-vicinity-lwt/dune | 14 + test/p2p-vicinity-lwt/test_vicinity_lwt.ml | 146 ++++ test/p2p-vicinity/dune | 9 + test/p2p-vicinity/test_vicinity.ml | 107 +++ test/p2p/dune | 4 + test/p2p/test_gossip.ml | 137 ++++ test/p2p/test_view.ml | 82 +++ 67 files changed, 4925 insertions(+) create mode 100644 .gitignore create mode 100644 LICENSE.md create mode 100644 Makefile create mode 100644 README.md create mode 100644 dune-project create mode 100644 lib/p2p-cyclon-lwt/dune create mode 100644 lib/p2p-cyclon-lwt/p2p_cyclon_lwt.ml create mode 100644 lib/p2p-cyclon-lwt/s.ml create mode 100644 lib/p2p-cyclon/dune create mode 100644 lib/p2p-cyclon/p2p_cyclon.ml create mode 100644 lib/p2p-cyclon/p2p_cyclon.mli create mode 100644 lib/p2p-poldercast-lwt/dune create mode 100644 lib/p2p-poldercast-lwt/p2p_poldercast_lwt.ml create mode 100644 lib/p2p-poldercast-lwt/s.ml create mode 100644 lib/p2p-poldercast/dune create mode 100644 lib/p2p-poldercast/node.ml create mode 100644 lib/p2p-poldercast/p2p-poldercast create mode 100644 lib/p2p-poldercast/p2p_poldercast.ml create mode 100644 lib/p2p-poldercast/s.ml create mode 100644 lib/p2p-ringcast-lwt/dune create mode 100644 lib/p2p-ringcast-lwt/p2p_ringcast_lwt.ml create mode 100644 lib/p2p-ringcast-lwt/s.ml create mode 100644 lib/p2p-ringcast/dune create mode 100644 lib/p2p-ringcast/p2p_ringcast.ml create mode 100644 lib/p2p-ringcast/s.ml create mode 100644 lib/p2p-vicinity-lwt/dune create mode 100644 lib/p2p-vicinity-lwt/p2p_vicinity_lwt.ml create mode 100644 lib/p2p-vicinity-lwt/s.ml create mode 100644 lib/p2p-vicinity/dune create mode 100644 lib/p2p-vicinity/p2p_vicinity.ml create mode 100644 lib/p2p-vicinity/s.ml create mode 100644 lib/p2p/dune create mode 100644 lib/p2p/group.ml create mode 100644 lib/p2p/group_id.ml create mode 100644 lib/p2p/msg_id.ml create mode 100644 lib/p2p/node.ml create mode 100644 lib/p2p/node_id.ml create mode 100644 lib/p2p/s.ml create mode 100644 lib/p2p/view.ml create mode 100644 p2p-cyclon-lwt.opam create mode 100644 p2p-cyclon.opam create mode 100644 p2p-poldercast-lwt.opam create mode 100644 p2p-poldercast.opam create mode 100644 p2p-ringcast-lwt.opam create mode 100644 p2p-ringcast.opam create mode 100644 p2p-vicinity-lwt.opam create mode 100644 p2p-vicinity.opam create mode 100644 p2p.opam create mode 100644 test/p2p-cyclon-lwt/dune create mode 100644 test/p2p-cyclon-lwt/test_cyclon_lwt.ml create mode 100644 test/p2p-cyclon/dune create mode 100644 test/p2p-cyclon/test_cyclon.ml create mode 100644 test/p2p-poldercast-lwt/dune create mode 100644 test/p2p-poldercast-lwt/test_poldercast_lwt.ml create mode 100644 test/p2p-poldercast/dune create mode 100644 test/p2p-poldercast/test_poldercast.ml create mode 100644 test/p2p-ringcast-lwt/dune create mode 100644 test/p2p-ringcast-lwt/test_ringcast_lwt.ml create mode 100644 test/p2p-ringcast/dune create mode 100644 test/p2p-ringcast/test_ringcast.ml create mode 100644 test/p2p-vicinity-lwt/dune create mode 100644 test/p2p-vicinity-lwt/test_vicinity_lwt.ml create mode 100644 test/p2p-vicinity/dune create mode 100644 test/p2p-vicinity/test_vicinity.ml create mode 100644 test/p2p/dune create mode 100644 test/p2p/test_gossip.ml create mode 100644 test/p2p/test_view.ml diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..06de165 --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +*~ +.* +\#* +_build +*.install diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 index 0000000..cba6f6a --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,660 @@ +### GNU AFFERO GENERAL PUBLIC LICENSE + +Version 3, 19 November 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 Affero General Public License is a free, copyleft license for +software and other kinds of works, specifically designed to ensure +cooperation with the community in the case of network server software. + +The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +our General Public Licenses are 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. + +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. + +Developers that use our General Public Licenses protect your rights +with two steps: (1) assert copyright on the software, and (2) offer +you this License which gives you legal permission to copy, distribute +and/or modify the software. + +A secondary benefit of defending all users' freedom is that +improvements made in alternate versions of the program, if they +receive widespread use, become available for other developers to +incorporate. Many developers of free software are heartened and +encouraged by the resulting cooperation. However, in the case of +software used on network servers, this result may fail to come about. +The GNU General Public License permits making a modified version and +letting the public access it on a server without ever releasing its +source code to the public. + +The GNU Affero General Public License is designed specifically to +ensure that, in such cases, the modified source code becomes available +to the community. It requires the operator of a network server to +provide the source code of the modified version running there to the +users of that server. Therefore, public use of a modified version, on +a publicly accessible server, gives the public access to the source +code of the modified version. + +An older license, called the Affero General Public License and +published by Affero, was designed to accomplish similar goals. This is +a different license, not a version of the Affero GPL, but Affero has +released a new version of the Affero GPL which permits relicensing +under this license. + +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 Affero 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. Remote Network Interaction; Use with the GNU General Public License. + +Notwithstanding any other provision of this License, if you modify the +Program, your modified version must prominently offer all users +interacting with it remotely through a computer network (if your +version supports such interaction) an opportunity to receive the +Corresponding Source of your version by providing access to the +Corresponding Source from a network server at no charge, through some +standard or customary means of facilitating copying of software. This +Corresponding Source shall include the Corresponding Source for any +work covered by version 3 of the GNU General Public License that is +incorporated pursuant to the following paragraph. + +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 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 work with which it is combined will remain governed by version +3 of the GNU General Public License. + +#### 14. Revised Versions of this License. + +The Free Software Foundation may publish revised and/or new versions +of the GNU Affero 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 Affero 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 Affero 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 Affero 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. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero 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 Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper +mail. + +If your software can interact with users remotely through a computer +network, you should also make sure that it provides a way for users to +get its source. For example, if your program is a web application, its +interface could display a "Source" link that leads users to an archive +of the code. There are many ways you could offer source, and different +solutions will be better for different programs; see section 13 for +the specific requirements. + +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 AGPL, see . diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..ec6fbb8 --- /dev/null +++ b/Makefile @@ -0,0 +1,15 @@ +.PHONY: all build doc test clean + +all: build doc test + +build: + dune build + +doc: + dune build @doc + +test: + dune runtest -f --no-buffer -j 1 + +clean: + dune clean diff --git a/README.md b/README.md new file mode 100644 index 0000000..e66046a --- /dev/null +++ b/README.md @@ -0,0 +1,56 @@ +[![Build Status](https://travis-ci.org/p2pcollab/ocaml-p2p.svg?branch=master)](https://travis-ci.org/p2pcollab/ocaml-p2p) + +# Gossip-based protocols for P2P collaboration + +P2Pcollab is a collacection of composable libraries +implementing gossip-based protocols for P2P collaboration. + +These libraries are distributed under the AGPL-3.0-only license. + +## Modules + +- PolderCast: P2P topic-based pub/sub +- RingCast: P2P hybrid dissemination +- VICINITY: P2P clustering & topology management +- CYCLON: Random Peer Sampling + +## Installation + +The libraries can be installed via `opam`: + + opam install p2p + opam install p2p-cyclon + opam install p2p-cyclon-lwt + opam install p2p-vicinity + opam install p2p-vicinity-lwt + opam install p2p-ringcast + opam install p2p-ringcast-lwt + opam install p2p-poldercast + opam install p2p-poldercast-lwt + +## Building + +To build from source, generate documentation, and run tests, use `dune`: + + dune build + dune build @doc + dune runtest -f -j1 --no-buffer + +In addition, the following `Makefile` targets are available + as a shorthand for the above: + + make + make build + make doc + make test + +## Documentation + +The documentation and API reference is generated from the source interfaces. +It can be consulted [online][doc] or via `odig`, e.g.: + + odig doc p2p + odig doc p2p-cyclon + ... + +[doc]: https://p2pcollab.net/doc/ocaml/ diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..7176f00 --- /dev/null +++ b/dune-project @@ -0,0 +1,2 @@ +(lang dune 1.3) +(name gossip) diff --git a/lib/p2p-cyclon-lwt/dune b/lib/p2p-cyclon-lwt/dune new file mode 100644 index 0000000..e5c0c9c --- /dev/null +++ b/lib/p2p-cyclon-lwt/dune @@ -0,0 +1,5 @@ +(library + (name p2p_cyclon_lwt) + (public_name p2p-cyclon-lwt) + (libraries p2p p2p-cyclon lwt lwt.unix) + (preprocess (pps lwt_ppx))) diff --git a/lib/p2p-cyclon-lwt/p2p_cyclon_lwt.ml b/lib/p2p-cyclon-lwt/p2p_cyclon_lwt.ml new file mode 100644 index 0000000..1a7c0dc --- /dev/null +++ b/lib/p2p-cyclon-lwt/p2p_cyclon_lwt.ml @@ -0,0 +1,141 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +(** +{1 CYCLON with Lwt} + +High-level library implementing the CYCLON protocol using Lwt. +*) + +(** Functor building an implementation of Cyclon with Lwt + given a [Node_id], [Node], gossip [View], [Cyclon] implementation, + and an [Io] event handler module. *) +module Make + (Node_id: P2p.S.NODE_ID) + (Node : P2p.S.NODE with type nid := Node_id.t) + (View : P2p.S.VIEW with type nid := Node_id.t + and type node := Node.t) + (Cyclon : P2p.S.GOSSIP with type node := Node.t + and type view := View.t) + (Io : S.CYCLON_IO with type nid := Node_id.t + and type node := Node.t + and type view := View.t) + : S.CYCLON with type nid := Node_id.t + and type node := Node.t + and type view := View.t + and type io := Io.t = struct + + module Gossip = Cyclon + + type t = { + me : Node.t; (** this node *) + mutable view : View.t; (** partial view of gossip protocol *) + view_len : int; (** max view length *) + xchg_len : int; (** max exchange length *) + period : float; (** gossip period in seconds *) + io : Io.t; + mutable stop : unit Lwt.t option; + mutable stopper : unit Lwt.u option; + } + + let init ~me ~view ~view_len ~xchg_len ~period ~io = + { me; view; view_len; xchg_len; period; io; + stop = None; stopper = None } + + let view t = t.view + + (** wait for [delay] seconds, + then return the result of thread [t], + or cancel it if not finished yet **) + let timeout delay stop t = + let%lwt _ = Lwt.choose [ Lwt_unix.sleep delay; stop ] in + match Lwt.state t with + | Lwt.Sleep -> Lwt.cancel t; Lwt.return None + | Lwt.Return v -> Lwt.return (Some v) + | Lwt.Fail ex -> Lwt.fail ex + + (** initiate exchange with a node from [t.view], + wait for response, and return merged view *) + let initiate t dst sent view = + match dst with + | (Some dst) -> + let%lwt recvd = Io.initiate_gossip t.io dst sent in + let%lwt recvd = Io.gossip_recvd t.io t.me recvd t.view in + t.view <- Gossip.merge ~view ~view_len:t.view_len ~me:t.me + ~sent ~recvd ~xchg_len:t.xchg_len; + let%lwt _ = Io.view_updated t.io t.me t.view in + Lwt.return t.view + | _ -> + Lwt.return t.view + + (** run initiator: + pick a random node from [t.view] to gossip with every [t.period] seconds *) + let run ?stop t = + match t.stop with + | Some stop -> stop + | None -> + let stop = + match stop with + | None -> + let (stop, stopper) = Lwt.wait () in + t.stopper <- Some stopper; + t.stop <- Some stop; + stop + | Some stop -> + t.stop <- Some stop; + stop in + + let rec loop () = + let (dst, sent, view_before) = + Gossip.initiate ~me:t.me ~view:t.view ~xview:View.empty + ~xchg_len:t.xchg_len in + let%lwt view_after = timeout t.period stop + (initiate t dst sent view_before) in + let _ = t.view <- match view_after with + | Some v -> v + | _ -> view_before in + match Lwt.state stop with + | Lwt.Sleep -> loop () + | _ -> Lwt.return_unit + in loop () + + let shutdown t = + match t.stopper with + | Some stopper -> + Lwt.wakeup_later stopper (); + t.stop <- None; + t.stopper <- None + | None -> + match t.stop with + | Some stop -> + Lwt.cancel stop; + t.stop <- None + | None -> () + + (** merge received entries from a node and send response *) + let respond t src recvd = + let sent = Gossip.respond ~view:t.view ~xview:View.empty + ~recvd ~src ~me:t.me ~xchg_len:t.xchg_len in + let%lwt _ = Io.respond_gossip t.io src sent in + let%lwt recvd = Io.gossip_recvd t.io src recvd t.view in + t.view <- Gossip.merge ~view:t.view ~view_len:t.view_len + ~sent ~recvd ~xchg_len:t.xchg_len ~me:t.me; + Lwt.return t.view + +end + +(** Signatures *) +module S = S diff --git a/lib/p2p-cyclon-lwt/s.ml b/lib/p2p-cyclon-lwt/s.ml new file mode 100644 index 0000000..299239b --- /dev/null +++ b/lib/p2p-cyclon-lwt/s.ml @@ -0,0 +1,86 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +module type CYCLON = sig + type t + type nid + type node + type view + type io + + val init : me:node -> view:view -> view_len:int -> xchg_len:int + -> period:float -> io:io -> t + (** [init node view view_len xchg_len period io] + initializes a CYCLON instance with the following configuration: + - [me] - this node + - [view] - initial view + - [view_len] - max view length + - [xchg_len] - number of entries to exchange at each period + - [period] - gossip period, in seconds + - [io] + *) + + val run : ?stop:unit Lwt.t -> t -> unit Lwt.t + (** [run t] runs initiator thread: + picks a random node from [view] to gossip with + every [period] seconds. + + If [?stop] is provided, this initiator thread returns + as soon as the [stop] thread is fulfilled. *) + + val shutdown : t -> unit + (** [shutdown t] stops initiator thread. + + In case [run] was called with a [stop] argument, + the [stop] thread is cancelled, otherwise it is fulfilled. *) + + val respond : t -> node -> view -> view Lwt.t + (** [respond t src recvd] + merges received entries from a node and sends response *) + + val view : t -> view + (** [view t] returns current view *) +end + + +module type CYCLON_IO = sig + type t + type nid + type node + type view + + val initiate_gossip : t -> node -> view -> view Lwt.t + (** [initiate_gossip dst xchg] + sends [xchg] entries to [node] + and returns response *) + + val respond_gossip : t -> node -> view -> unit Lwt.t + (** [respond_gossip t src xchg] + sends [xchg] entries in response to [node] *) + + val gossip_recvd : t -> node -> view -> view -> view Lwt.t + (** [gossip_recvd t src recvd view] + is called after entries are received during an exchange; + allows rewriting [recvd] entries with the returned value, + thus allows using a stream sampler such as URPS + to provide uniformly random nodes + instead of the possibly biased exchanged nodes *) + + val view_updated : t -> node -> view -> unit Lwt.t + (** [view_updated node view] + is called when [view] has been updated + after a gossip exchange with [node] *) +end diff --git a/lib/p2p-cyclon/dune b/lib/p2p-cyclon/dune new file mode 100644 index 0000000..e4a9d02 --- /dev/null +++ b/lib/p2p-cyclon/dune @@ -0,0 +1,4 @@ +(library + (name p2p_cyclon) + (public_name p2p-cyclon) + (libraries p2p)) diff --git a/lib/p2p-cyclon/p2p_cyclon.ml b/lib/p2p-cyclon/p2p_cyclon.ml new file mode 100644 index 0000000..be821c4 --- /dev/null +++ b/lib/p2p-cyclon/p2p_cyclon.ml @@ -0,0 +1,75 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +(** Functor building an implementation of Cyclon + given a [Node_id], [Node], and gossip [View]. *) +module Make + (Node_id : P2p.S.NODE_ID) + (Node : P2p.S.NODE with type nid := Node_id.t) + (View : P2p.S.VIEW with type nid := Node_id.t + and type node := Node.t) + : P2p.S.GOSSIP with type node := Node.t + and type view := View.t = struct + + let initiate ~view ~xview ~me ~xchg_len = + let dst = View.oldest view in + match dst with + | Some dst -> + let view = View.remove (Node.id dst) view in + let view = View.incr_age view in + let uview = View.union view xview in + let xchg = View.random_subset (xchg_len - 1) uview in + let xchg = View.add me xchg in + (Some dst, xchg, view) + | None -> (* view empty *) + (None, View.empty, view) + + let respond ~view ~xview ~recvd ~src ~me ~xchg_len = + let _recvd = recvd and _src = src and _me = me in + let uview = View.union view xview in + View.random_subset xchg_len uview + + let merge ~view ~view_len ~sent ~recvd ~xchg_len ~me = + let sent = View.remove (Node.id me) sent in + let recvd = View.remove (Node.id me) recvd in + let recvd = View.random_subset xchg_len recvd in + let recvd = View.zero_age recvd in + let rec merge view sent recvd = + if 0 < View.length recvd then + match View.random recvd with + | (Some rnode) -> + if View.length view < view_len then + (* fill an empty slot in view *) + let view = View.add rnode view in + let recvd = View.remove (Node.id rnode) recvd in + merge view sent recvd + else (* replace a sent entry in view with a received one *) + (match View.random sent with + | Some snode -> + let view = View.add rnode view in + let view = + if view_len < View.length view + then View.remove (Node.id snode) view + else view in + let sent = View.remove (Node.id snode) sent in + let recvd = View.remove (Node.id rnode) recvd in + merge view sent recvd + | _ -> view) + | _ -> view + else view in + merge view sent recvd + +end diff --git a/lib/p2p-cyclon/p2p_cyclon.mli b/lib/p2p-cyclon/p2p_cyclon.mli new file mode 100644 index 0000000..6bec4bf --- /dev/null +++ b/lib/p2p-cyclon/p2p_cyclon.mli @@ -0,0 +1,54 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +(** + +{1 CYCLON: Inexpensive Membership Management for Unstructured P2P Overlays} + +This is an OCaml implementation of the CYCLON protocol as specified in the paper +{{:https://www.distributed-systems.net/my-data/papers/2005.jnsm.pdf} +CYCLON: Inexpensive Membership Managementfor Unstructured P2P Overlays}. + +{2 Protocol} + ++ Increase by one the age of all neighbors. ++ Select neighbor {e Q} with the highest age among all neighbors, and {e l - 1} other random neighbors. ++ Replace {e Q}'s entry with a new entry of age 0 and with {e P}'s address. ++ Send the updated subset to peer {e Q}. ++ Receive from {e Q} a subset of no more that {e i} of its own entries. ++ Discard entries pointing at {e P} and entries already contained in {e P}'s cache. ++ Update {e P}'s cache to include {e all} remaining entries, by {e firstly} using empty cache slots (if any), + and {e secondly} replacing entries among the ones sent to {e Q}. + +{e Quoted from the paper above.} + +{2 Security} + +CYCLON is not secure against malicious nodes deviating from the protocol. +See {{:https://github.com/p2pcollab/ocaml-urps} URPS} for a stream sampler +implementation that achieves uniformity in presence of malicious nodes +and which can be used together with CYCLON. +*) + +open P2p + +module Make + (Node_id : S.NODE_ID) + (Node : S.NODE with type nid := Node_id.t) + (View : S.VIEW with type nid := Node_id.t + and type node := Node.t) + : S.GOSSIP with type node := Node.t + and type view := View.t diff --git a/lib/p2p-poldercast-lwt/dune b/lib/p2p-poldercast-lwt/dune new file mode 100644 index 0000000..6c0a3f1 --- /dev/null +++ b/lib/p2p-poldercast-lwt/dune @@ -0,0 +1,14 @@ +(library + (name p2p_poldercast_lwt) + (public_name p2p-poldercast-lwt) + (libraries p2p + p2p-poldercast + p2p-ringcast + p2p-ringcast-lwt + p2p-vicinity + p2p-vicinity-lwt + p2p-cyclon + p2p-cyclon-lwt + lwt + lwt.unix) + (preprocess (pps lwt_ppx))) diff --git a/lib/p2p-poldercast-lwt/p2p_poldercast_lwt.ml b/lib/p2p-poldercast-lwt/p2p_poldercast_lwt.ml new file mode 100644 index 0000000..0a3dbe4 --- /dev/null +++ b/lib/p2p-poldercast-lwt/p2p_poldercast_lwt.ml @@ -0,0 +1,164 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +(** +{1 PolderCast with Lwt} + +High-level library implementing the PolderCast protocol using Lwt. +*) + +(** Functor building an implementation of Poldercast with Lwt + given a FIXME [Node_id], [Node], gossip [View], PolderCast [Gossip] protocol, + and an [Io] event handler module. *) +module Make + (Node_id : P2p.S.NODE_ID) + (Group_id: P2p.S.GROUP_ID) + (Node : P2p.S.NODE with type nid := Node_id.t) + (Group: P2p.S.GROUP with type gid := Group_id.t) + (View : P2p.S.VIEW with type nid := Node_id.t + and type node := Node.t) + (Msg_id : P2p.S.MSG_ID) + (Ringcast : P2p.S.GOSSIP_DISSEM with type nid := Node_id.t + and type node := Node.t + and type view := View.t + and type mid := Msg_id.t) + (Ringcast_io : P2p_ringcast_lwt.S.RINGCAST_IO with type nid := Node_id.t + and type node := Node.t + and type view := View.t + and type mid := Msg_id.t) + (Ringcast_lwt : P2p_ringcast_lwt.S.RINGCAST with type nid := Node_id.t + and type node := Node.t + and type view := View.t + and type mid := Msg_id.t + and type io := Ringcast_io.t) + (Poldercast : P2p_poldercast.S.PUBSUB with type nid := Node_id.t + and type gid := Group_id.t + and type node := Node.t + and type group := Group.t + and type view := View.t + and type mid := Msg_id.t) + : S.POLDERCAST with type nid := Node_id.t + and type gid := Group_id.t + and type node := Node.t + and type group := Group.t + and type view := View.t + and type mid := Msg_id.t + and type ring := P2p_ringcast_lwt.Make + (Node_id) (Node) (View) (Msg_id) + (Ringcast) (Ringcast_io) .t + and type ring_io := Ringcast_io.t = struct + + module Pub = Poldercast.Pub + module Sub = Poldercast.Sub + module RCL = P2p_ringcast_lwt.Make (Node_id) (Node) (View) (Msg_id) + (Ringcast) (Ringcast_io) + + (** data associated with a subscription *) + type sub = { + me : Node.t; + group : Group.t; + ring : RCL.t; + ring_t : unit Lwt.t; + stop : unit Lwt.t; + io : Ringcast_io.t; + } + + type t = { + me : Node.t; + view_len : int; + xchg_len : int; + period : float; + fanout : int; + seen_len : int; + subs : sub Poldercast.Sub.t; (** Group_id.t -> sub *) + io : (Group.t -> Ringcast_io.t); + stop : unit Lwt.t; + stopper : unit Lwt.u option; + } + + let sub ?(view=View.empty) t group = + let io = t.io group in + let ring = RCL.init + ~me:t.me ~view ~view_len:t.view_len + ~xchg_len:t.xchg_len ~period:t.period ~fanout:t.fanout + ~seen_len:t.seen_len ~io in + let stop = Lwt.choose [ fst (Lwt.task ()); t.stop ] in + let ring_t = RCL.run ring ~stop in + let sub = { me = t.me; group; ring; ring_t; stop; io } in + let subs = Sub.add group sub t.subs in + { t with subs } + + let unsub t gid = + match Sub.find gid t.subs with + | Some (_group, sub) -> + let () = Lwt.cancel sub.stop in + let subs = Sub.remove gid t.subs in + Ok { t with subs } + | None -> Error "Group not found" + + let init ~me ?max_subs ~view_len ~xchg_len ~period ~fanout ~seen_len + ?(sub_list = []) ?stop ~io = + let subs = match max_subs with + | Some max_subs -> Sub.init max_subs + | None -> Sub.empty in + let (stop, stopper) = + match stop with + | None -> + let (stop, stopper) = Lwt.wait () in + (stop, Some stopper) + | Some stop -> + (stop, None) in + let t = { me; subs; view_len; xchg_len; period; fanout; seen_len; io; + stop; stopper } in + List.fold_left + (fun t (group, view) -> + sub t group ~view) + t sub_list + + let run t = + t.stop + + let shutdown t = + match t.stopper with + | Some stopper -> + Lwt.wakeup_later stopper (); + | None -> + Lwt.cancel t.stop + + let find t gid = + match Sub.find gid t.subs with + | Some (_group, sub) -> + Some sub.ring + | None -> None + + let view t = + Sub.fold + (fun _gid (_group, sub) view -> + View.union view (RCL.view sub.ring)) + t.subs View.empty + + let to_list t = + Sub.fold + (fun _gid data lst -> + let (group, sub) = data in + let view = (RCL.view sub.ring) in + (group, view) :: lst) + t.subs [] + +end + +(** Signatures *) +module S = S diff --git a/lib/p2p-poldercast-lwt/s.ml b/lib/p2p-poldercast-lwt/s.ml new file mode 100644 index 0000000..d556cca --- /dev/null +++ b/lib/p2p-poldercast-lwt/s.ml @@ -0,0 +1,74 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +module type POLDERCAST = sig + type t + type nid + type gid + type node + type group + type view + type mid + type ring + type ring_io + + val init : me:node -> ?max_subs:int -> view_len:int -> xchg_len:int + -> period:float -> fanout:int -> seen_len:int + -> ?sub_list:(group * view) list -> ?stop:unit Lwt.t + -> io:(group -> ring_io) -> t + (** [init node view view_len xchg_len period fanout seen_cap] + initializes a PolderCast instance with the following configuration. + + @param me this node + @param view initial view + @param view_len max view length + @param xchg_len number of entries to exchange at each period + @param period gossip period, in seconds + @param fanout dissemination fanout + @param seen_len length of queue of last seen message IDs + @param stop thread that shuts down all groups when cancelled + *) + + val run : t -> unit Lwt.t + (** [run t] returns a promise that is fulfilled upon [shutdown] *) + + val shutdown : t -> unit + (** [shutdown t] shuts down all subscribed groups. + + After calling this function, [sub] cannot be called again with [t]. *) + + val sub : ?view:view -> t -> group -> t + (** [sub ?view t group] subscribes to [group] with initial [view] *) + + val unsub : t -> gid -> (t, string) result + (** [unsub t gid] unsubscribes from group with ID [gid] *) + + val find : t -> gid -> ring option + + val view : t -> view + (** [view t] returns the combined view of all subscribed groups *) + + val to_list : t -> (group * view) list + (** [to_list t] returns a list of [(group, view)] pairs + of all subscribed groups paired with their current membership view *) +end + +module type RINGCAST_IO = sig + include P2p_ringcast_lwt.S.RINGCAST_IO + type group + + val init : 'a -> group -> t +end diff --git a/lib/p2p-poldercast/dune b/lib/p2p-poldercast/dune new file mode 100644 index 0000000..5e6c676 --- /dev/null +++ b/lib/p2p-poldercast/dune @@ -0,0 +1,4 @@ +(library + (name p2p_poldercast) + (public_name p2p-poldercast) + (libraries p2p p2p-ringcast bloomf blip)) diff --git a/lib/p2p-poldercast/node.ml b/lib/p2p-poldercast/node.ml new file mode 100644 index 0000000..0e4e6e0 --- /dev/null +++ b/lib/p2p-poldercast/node.ml @@ -0,0 +1,72 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +module Make + (Node_id: P2p.S.NODE_ID) + : S.NODE with type nid := Node_id.t = struct + + module Node = P2p.Node.Make (Node_id) + + type node = Node.t + type t = { + node : node; + subs : Bitv.t; + } + + (** Base *) + + let id t = Node.id t.node + let age t = Node.age t.node + let ver t = Node.ver t.node + let zero_age t = { t with node = Node.zero_age t.node } + let incr_age t = { t with node = Node.incr_age t.node } + let set_age t age = { t with node = Node.set_age t.node age } + let set_ver t ver = { t with node = Node.set_ver t.node ver } + let incr_ver t = { t with node = Node.incr_ver t.node } + + let compare a b = Node.compare a.node b.node + + let distance a b = Node.distance a.node b.node + + let distance_ring a b = Node.distance_ring a.node b.node + + (** Extensions *) + + let init ?age ?ver id = + let node = Node.init ?age ?ver id in + let subs = Bitv.create 0 false in + { node; subs } + + let subs t = + t.subs + + let set_subs t subs = + { t with subs } + + let sim a b = + Blip.sim a.subs b.subs + + let to_string t = + let buf = Buffer.create (Bitv.length t.subs) in + Bitv.iter + (fun b -> Buffer.add_char buf (char_of_int (if b then 1 else 0))) t.subs; + Printf.sprintf "%s\n%s\n" (Node.to_string t.node) (Buffer.contents buf) + + let pp ppf t = + Node.pp ppf t.node; + Bitv.iter (fun b -> Fmt.pf ppf "%d" (if b then 1 else 0)) t.subs + +end diff --git a/lib/p2p-poldercast/p2p-poldercast b/lib/p2p-poldercast/p2p-poldercast new file mode 100644 index 0000000..7f12329 --- /dev/null +++ b/lib/p2p-poldercast/p2p-poldercast @@ -0,0 +1,16 @@ + /home/dev/src/p2pcollab/ocaml-p2p/lib/p2p-poldercast: + total used in directory 48K available 33652480 + drwxr-xr-x 1 dev dev 258 Sep 26 16:46 . + drwxr-xr-x 1 dev dev 266 Jun 5 19:30 .. + -rw-r--r-- 1 dev dev 109 Sep 26 01:26 dune + -rw-r--r-- 1 dev dev 2,2K Sep 26 01:26 .merlin + -rw-r--r-- 1 dev dev 980 Sep 26 16:46 .node.ml + -rw-r--r-- 1 dev dev 324 Sep 26 13:43 node.ml~ + -rw-r--r-- 1 dev dev 332 Sep 26 13:22 node_profile.ml + -rw-r--r-- 1 dev dev 187 Sep 25 14:29 node_profile.ml~ + -rw-r--r-- 1 dev dev 259 Sep 26 03:23 .p2p_poldercast.ml + -rw-r--r-- 1 dev dev 2,4K Sep 26 11:25 p2p_poldercast.ml + -rw-r--r-- 1 dev dev 1,8K May 24 17:38 p2p_poldercast.ml~ + -rw-r--r-- 1 dev dev 184 Mar 15 2019 seenq.ml~ + -rw-r--r-- 1 dev dev 588 Sep 26 16:20 .s.ml + -rw-r--r-- 1 dev dev 222 Sep 25 15:07 s.ml~ diff --git a/lib/p2p-poldercast/p2p_poldercast.ml b/lib/p2p-poldercast/p2p_poldercast.ml new file mode 100644 index 0000000..b82f4af --- /dev/null +++ b/lib/p2p-poldercast/p2p_poldercast.ml @@ -0,0 +1,154 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +(** +{1 PolderCast: P2P Topic-based Pub/Sub} + +This is an OCaml implementation of PolderCast, +a P2P topic-based pub/sub protocol described in the paper +{{:https://hal.inria.fr/hal-01555561} PolderCast: Fast, Robust, and Scalable Architecture for P2P Topic-Based Pub/Sub} + +It relies on three different gossip protocols: +- Random Peer Sampling, to find random nodes in the network. See the {!P2p_cyclon}module. +- Clustering, to find nodes with overlapping subscriptions. See the {!P2p_vicinity} module. +- Dissemination, for the dissemination of messages within a topic. See the {!P2p_ringcast} module. + +{2 Privacy} + +PolderCast, as specified in the paper, employs VICINITY for clustering, +and transmits full node subscription profiles in the clear. +See {{:https://github.com/p2pcollab/ocaml-blip} BLIP} for a privacy mechanism +that transmits subscriptions as randomized Bloom filters instead, +and {{:https://github.com/p2pcollab/ocaml-psi} BFPSI}, +a Bloom filter-based Private Set Intersection protocol +to determine common subscriptions of two nodes. +*) + +(** PolderCast*) +module Make + (Node_id: P2p.S.NODE_ID) + (Group_id: P2p.S.GROUP_ID) + (Node: S.NODE with type nid := Node_id.t) + (Group: P2p.S.GROUP with type gid := Group_id.t) + (View: P2p.S.VIEW with type nid := Node_id.t + and type node := Node.t) + (Msg_id: P2p.S.MSG_ID) + (Pub : P2p.S.GOSSIP_DISSEM with type nid := Node_id.t + and type node := Node.t + and type view := View.t + and type mid := Msg_id.t) + : S.PUBSUB with type nid := Node_id.t + and type node := Node.t + and type view := View.t + and type mid := Msg_id.t + and type gid := Group_id.t + and type group := Group.t = struct + + (** Publishing *) + module Pub = Pub + + (** Subscriptions of this node *) + module Sub = struct + module Subs = Map.Make (Group_id) + + type group = Group.t + + type 'a t = { + subs : (group * 'a) Subs.t; (** subscriptions: gid -> group *) + bf : Group_id.t Bloomf.t; + mutable bf_dirty : bool; + b : Bitv.t; + } + + let init max_subs = + let subs = Subs.empty in + let bf = Bloomf.create max_subs in + let b = Bloomf.bits bf in + { subs; bf; b; bf_dirty = false } + + let empty = + init 1000 + + let rebuild_bf t = + Bloomf.clear t.bf; + Subs.iter (fun gid _group -> Bloomf.add t.bf gid) t.subs; + t.bf_dirty <- false + + (** subscribe to [group] with ID [gid] *) + let add group data t = + let gid = Group.id group in + let subs = Subs.add gid (group, data) t.subs in + Bloomf.add t.bf gid; + { t with subs } + + let remove gid t = + let subs = Subs.remove gid t.subs in + { t with subs; bf_dirty = true } + + let bloom t = + if t.bf_dirty then rebuild_bf t; + Bloomf.bits t.bf + + let blip t e = + let _m, k = Bloomf.params t.bf in + Blip.flip (bloom t) (Blip.p e k) + + let length t = + Subs.cardinal t.subs + + let is_empty t = + Subs.is_empty t.subs + + let mem gid t = + Subs.mem gid t.subs + + let find gid t = + Subs.find_opt gid t.subs + + let filter f t = + let subs = Subs.filter f t.subs in + { t with subs } + + let fold f t a = + Subs.fold f t.subs a + + let iter f t = + Subs.iter f t.subs + + let map f t = + let subs = Subs.mapi f t.subs in + { t with subs } + + let to_list t = + List.map + (fun (_gid, group) -> group) + (Subs.bindings t.subs) + + let of_list max_subs l = + List.fold_left + (fun t (group, data) -> + add group data t) + (init max_subs) l + + end + +end + +(** Signatures *) +module S = S + +(** Node *) +module Node = Node diff --git a/lib/p2p-poldercast/s.ml b/lib/p2p-poldercast/s.ml new file mode 100644 index 0000000..0177230 --- /dev/null +++ b/lib/p2p-poldercast/s.ml @@ -0,0 +1,74 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +(** Node *) +module type NODE = sig + + include P2p.S.NODE + + (** Subscriptions of node *) + val subs : t -> Bitv.t + + val set_subs : t -> Bitv.t -> t + + val sim : t -> t -> float +end + +(** Subscriptions of this node to groups *) +module type SUBSCRIPTION = sig + + include P2p.S.SUBSCRIPTION + + val init : int -> 'a t + (** [int max_subs] initializes an empty subscription set + with [max_subs] maximum number of subscriptions expected. *) + + val of_list : int -> (group * 'a) list -> 'a t + (** [of_list max_subs sub_list] initializes a subscription set + from a list of (group, metadata) pairs *) + + val bloom : 'a t -> Bitv.t + (** [bloom t] returns a bloom filter with the subscribed group IDs inserted. *) + + val blip : 'a t -> float -> Bitv.t + (** [blip t e] is [bloom] with independent random bit flips. + + @param e Differential privacy parameter ε. + Determines the privacy-utility trade-off. + See {! Blip.p} in the documentation of the [Blip] module. *) +end + +(** Publish-subscribe message dissemination *) +module type PUBSUB = sig + type nid + type node + type view + type mid + type gid + type group + + module Pub : sig + include P2p.S.GOSSIP_DISSEM + with type nid := nid + and type node := node + and type view := view + and type mid := mid + end + + module Sub : SUBSCRIPTION + with type gid := gid + and type group := group +end diff --git a/lib/p2p-ringcast-lwt/dune b/lib/p2p-ringcast-lwt/dune new file mode 100644 index 0000000..cfc193d --- /dev/null +++ b/lib/p2p-ringcast-lwt/dune @@ -0,0 +1,5 @@ +(library + (name p2p_ringcast_lwt) + (public_name p2p-ringcast-lwt) + (libraries p2p p2p-ringcast lwt lwt.unix lru) + (preprocess (pps lwt_ppx))) diff --git a/lib/p2p-ringcast-lwt/p2p_ringcast_lwt.ml b/lib/p2p-ringcast-lwt/p2p_ringcast_lwt.ml new file mode 100644 index 0000000..ed28f83 --- /dev/null +++ b/lib/p2p-ringcast-lwt/p2p_ringcast_lwt.ml @@ -0,0 +1,166 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +(** +{1 RingCast with Lwt} + +High-level library implementing the RingCast protocol using Lwt. +*) + +(** Functor building an implementation of Ringcast with Lwt + given a [Node_id], [Node], gossip [View], RingCast [Gossip] protocol, + and an [Io] event handler module. *) +module Make + (Node_id : P2p.S.NODE_ID) + (Node : P2p.S.NODE with type nid := Node_id.t) + (View : P2p.S.VIEW with type nid := Node_id.t + and type node := Node.t) + (Msg_id : P2p.S.MSG_ID) + (Ringcast : P2p.S.GOSSIP_DISSEM with type nid := Node_id.t + and type node := Node.t + and type view := View.t + and type mid := Msg_id.t) + (Io : S.RINGCAST_IO with type nid := Node_id.t + and type node := Node.t + and type view := View.t + and type mid := Msg_id.t) + : S.RINGCAST with type nid := Node_id.t + and type node := Node.t + and type view := View.t + and type mid := Msg_id.t + and type io := Io.t = struct + + module Gossip = Ringcast + + type t = { + me : Node.t; (** this node *) + mutable view : View.t; (** partial view of gossip protocol *) + view_len : int; (** max view length *) + xchg_len : int; (** max exchange length *) + period : float; (** gossip period in seconds *) + fanout : int; + io : Io.t; + mutable seen : Gossip.seen; + mutable stop : unit Lwt.t option; + mutable stopper : unit Lwt.u option; + } + + let init ~me ~view ~view_len ~xchg_len ~period ~fanout ~seen_len ~io = + let seen = Gossip.init_seen seen_len in + { me; view; view_len; xchg_len; period; fanout; seen; io; + stop = None; stopper = None; } + + let view t = t.view + + (** Wait for [delay] seconds, + then return the result of thread [t], + or cancel it if not finished yet **) + let timeout delay stop t = + let%lwt _ = Lwt.choose [ Lwt_unix.sleep delay; stop ] in + match Lwt.state t with + | Lwt.Sleep -> Lwt.cancel t; Lwt.return None + | Lwt.Return v -> Lwt.return (Some v) + | Lwt.Fail ex -> Lwt.fail ex + + (** Initiate exchange with a node from [t.view], + wait for response, and return merged view. *) + let initiate t dst sent view = + match dst with + | (Some dst) -> + let%lwt recvd = Io.initiate_gossip t.io dst sent in + let%lwt recvd = Io.gossip_recvd t.io dst recvd t.view in + t.view <- Gossip.merge ~view ~view_len:t.view_len ~me:t.me + ~sent ~recvd ~xchg_len:t.xchg_len; + let%lwt _ = Io.view_updated t.io t.me t.view in + Lwt.return t.view + | _ -> + Lwt.return t.view + + (** Run active thread. + Pick a random node from [t.view] to gossip with + every [t.period] seconds. *) + let run ?stop t = + match t.stop with + | Some stop -> stop + | None -> + let stop = + match stop with + | None -> + let (stop, stopper) = Lwt.wait () in + t.stopper <- Some stopper; + t.stop <- Some stop; + stop + | Some stop -> + t.stop <- Some stop; + stop in + + let rec loop () = + let xview = Io.get_xview t.io in + let (dst, sent, view_before) = + Gossip.initiate ~me:t.me ~view:t.view ~xview + ~xchg_len:t.xchg_len in + let%lwt view_after = timeout t.period stop (initiate t dst sent view_before) in + let _ = t.view <- match view_after with + | Some v -> v + | _ -> view_before in + match Lwt.state stop with + | Lwt.Sleep -> loop () + | _ -> Lwt.return_unit + in loop () + + let shutdown t = + match t.stopper with + | Some stopper -> + Lwt.wakeup_later stopper (); + t.stop <- None; + t.stopper <- None + | None -> + match t.stop with + | Some stop -> + Lwt.cancel stop; + t.stop <- None + | None -> () + + (** Merge received entries from a node and send response *) + let respond t src recvd = + let xview = Io.get_xview t.io in + let sent = Gossip.respond ~view:t.view ~xview + ~recvd ~src ~me:t.me ~xchg_len:t.xchg_len in + let%lwt _ = Io.respond_gossip t.io src sent in + let%lwt recvd = Io.gossip_recvd t.io src recvd t.view in + t.view <- Gossip.merge ~view:t.view ~view_len:t.view_len + ~sent ~recvd ~xchg_len:t.xchg_len ~me:t.me; + Lwt.return t.view + + (** Forward [msg] with ID [mid] from [src] to [t.fanout] nodes in [t.view] *) + let forward t src mid msg = + let (targets, seen) = + Gossip.forward ~view:t.view ~seen:t.seen ~mid + ~src ~me:t.me ~fanout:t.fanout + in + View.iter + (fun _nid node -> + let _ = + let%lwt _ = Io.send_msg t.io node mid msg + in Lwt.return_unit + in ()) targets; + t.seen <- seen; + Lwt.return_unit + +end + +(** Signatures *) +module S = S diff --git a/lib/p2p-ringcast-lwt/s.ml b/lib/p2p-ringcast-lwt/s.ml new file mode 100644 index 0000000..3a7e2ec --- /dev/null +++ b/lib/p2p-ringcast-lwt/s.ml @@ -0,0 +1,102 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +module type RINGCAST = sig + type t + type nid + type node + type view + type mid + type io + + val init : me:node -> view:view -> view_len:int -> xchg_len:int -> period:float + -> fanout:int -> seen_len:int -> io:io -> t + (** [init node view view_len xchg_len period fanout seen_cap] + initializes a RingCast instance with the following configuration. + + @param me this node + @param view initial view + @param view_len max view length + @param xchg_len number of entries to exchange at each period + @param period gossip period, in seconds + @param fanout dissemination fanout + @param seen_len length of queue of last seen message IDs + *) + + val run : ?stop:unit Lwt.t -> t -> unit Lwt.t + (** [run ?stop t] runs initiator thread: + picks a random node from [view] to gossip with + every [period] seconds. + + If [?stop] is provided, this initiator thread returns + as soon as the [stop] thread is fulfilled. *) + + val shutdown : t -> unit + (** [shutdown t] stops initiator thread. + + In case [run] was called with a [stop] argument, + the [stop] thread is cancelled, otherwise it is fulfilled. *) + + val respond : t -> node -> view -> view Lwt.t + (** [respond t node recvd] + merges received entries from a node and sends response *) + + val forward : t -> node -> mid -> Cstruct.t -> unit Lwt.t + (** [forward t src mid msg] + receives a message ([msgid, msg]) from a [src] node and + selects nodes from the local view it should be forwarded to + (predecessor or successor on the ring and some random nodes, + limited by [fanout]); + calls [Io.send_msg] for each selected node *) + + val view : t -> view + (** [view t] returns current view *) +end + +module type RINGCAST_IO = sig + type t + type nid + type mid + type node + type view + + val initiate_gossip : t -> node -> view -> view Lwt.t + (** [initiate_gossip t node xchg] + sends [xchg] entries to [node] + and returns response *) + + val respond_gossip : t -> node -> view -> unit Lwt.t + (** [respond_gossip t node xchg] + sends [xchg] entries in response to [node] *) + + val gossip_recvd : t -> node -> view -> view -> view Lwt.t + (** [gossip_recvd t src recvd view] + is called after entries are received during an exchange; + allows rewriting [recvd] entries with the returned value. *) + + val view_updated : t -> node -> view -> unit Lwt.t + (** [view_updated t node view] + is called when [view] has been updated + after a gossip exchange with [node] *) + + val get_xview : t -> view + (** [get_xview t] + is called before selecting entries for a gossip exchange + and should return the view of other gossip protocol(s), if any. *) + + val send_msg : t -> node -> mid -> Cstruct.t -> unit Lwt.t + (** [send_msg t dst msgid msg] *) +end diff --git a/lib/p2p-ringcast/dune b/lib/p2p-ringcast/dune new file mode 100644 index 0000000..e801945 --- /dev/null +++ b/lib/p2p-ringcast/dune @@ -0,0 +1,4 @@ +(library + (name p2p_ringcast) + (public_name p2p-ringcast) + (libraries p2p lru)) diff --git a/lib/p2p-ringcast/p2p_ringcast.ml b/lib/p2p-ringcast/p2p_ringcast.ml new file mode 100644 index 0000000..a4b002c --- /dev/null +++ b/lib/p2p-ringcast/p2p_ringcast.ml @@ -0,0 +1,213 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +(** +{1 RingCast: P2P hybrid dissemination protocol} + +This is an OCaml implementation of RingCast, +a P2P hybrid (probabilistic/deterministic) dissemination protocol +described in the paper +{{:https://hal.inria.fr/hal-01555561} PolderCast} +(and earlier in +{{:https://www.distributed-systems.net/my-data/papers/2007.mw.pdf} +Hybrid Dissemination}. + +It organizes nodes in a bidirectional ring structure +and forwards messages to neighbours as well as random nodes. +It achieves complete dissemination of messages with a low message overhead. +*) + +(** Functor building an implementation of Ringcast + given a Node_id, Node, gossip View, and Msg_id. *) +module Make + (Node_id: P2p.S.NODE_ID) + (Node: P2p.S.NODE with type nid := Node_id.t) + (View: P2p.S.VIEW with type nid := Node_id.t + and type node := Node.t) + (Msg_id: P2p.S.MSG_ID) + : S.GOSSIP_DISSEM with type nid := Node_id.t + and type node := Node.t + and type view := View.t + and type mid := Msg_id.t = struct + + module W = struct + type t = int + let weight _ = 1 + end + + module Rng = Nocrypto.Rng + module SeenQ = Lru.F.Make(Msg_id)(W) + + type seen = SeenQ.t + + type dist = + { + node: Node.t; + dir: int; + dist: Node_id.t; + } + + (** selects [len] closest neighbours to [dst] from [view] + (len/2 with lower and len/2 with higher ID) *) + let closest ~view ~dst ~len = + let dlist = + List.stable_sort + (fun n1 n2 -> + Node_id.compare n1.dist n2.dist) + (List.sort + (fun _n1 _n2 -> if Rng.Int.gen 2 = 0 then 1 else -1) + (View.fold + (fun _nid node lst -> + let (dir, dist) = Node.distance_ring dst node in + { node; dir; dist } :: lst) + view [])) in + let (dview_lo, dview_hi) = + List.fold_left + (fun (dview_lo, dview_hi) dnode -> + let dview_lo = + if dnode.dir < 0 then + if View.length dview_lo < len / 2 then + View.add dnode.node dview_lo + else dview_lo + else dview_lo in + let dview_hi = + if 0 < dnode.dir then + if View.length dview_hi < len / 2 then + View.add dnode.node dview_hi + else dview_hi + else dview_hi in + (dview_lo, dview_hi)) + (View.empty, View.empty) + dlist + in + View.union dview_lo dview_hi + + (** find the closest neighbour with lower ID to [dst] from [view] *) + let predecessor ~view ~dst = + let dlist = + List.stable_sort + (fun n1 n2 -> + compare n1.dist n2.dist) + (List.sort + (fun _n1 _n2 -> if Rng.Int.gen 2 = 0 then 1 else -1) + (View.fold + (fun _nid node lst -> + let (dir, dist) = Node.distance_ring dst node in + { node; dir; dist } :: lst) + view [])) in + match + List.nth_opt + (List.filter + (fun dnode -> dnode.dir < 0) + dlist) + 0 with + | Some dnode -> Some dnode.node + | None -> None + + (** find the closest neighbour with lower ID to [dst] from [view] *) + let successor ~view ~dst = + let dlist = + List.stable_sort + (fun n1 n2 -> + compare n1.dist n2.dist) + (List.sort + (fun _n1 _n2 -> if Rng.Int.gen 2 = 0 then 1 else -1) + (View.fold + (fun _nid node lst -> + let (dir, dist) = Node.distance_ring dst node in + { node; dir; dist } :: lst) + view [])) in + match + List.nth_opt + (List.filter + (fun dnode -> 0 < dnode.dir) + dlist) + 0 with + | Some dnode -> Some dnode.node + | None -> None + + let initiate ~view ~xview ~me ~xchg_len = + let dst = View.oldest view in + match dst with + | Some dst -> + let view = View.remove (Node.id dst) view in + let view = View.incr_age view in + let uview = View.union view xview in + let xchg = closest ~dst:me ~len:xchg_len ~view:uview in + let xchg = View.random_subset (xchg_len-1) xchg in + let xchg = View.add me xchg in + (Some dst, xchg, view) + | None -> + (None, View.empty, view) + + let respond ~view ~xview ~recvd ~src ~me ~xchg_len = + let uview = View.add me view in + let uview = View.union uview xview in + let uview = View.filter (* remove recvd nodes *) + (fun nid _node -> not (View.mem nid recvd)) + uview in + closest ~dst:src ~len:xchg_len ~view:uview + + let merge ~view ~view_len ~sent ~recvd ~xchg_len ~me = + let _sent = sent in + let recvd = View.remove (Node.id me) recvd in + let recvd = View.random_subset xchg_len recvd in + let recvd = View.zero_age recvd in + let uview = View.union view recvd in + closest ~dst:me ~len:view_len ~view:uview + + let init_seen seen_len = + SeenQ.empty seen_len + + let forward ~view ~seen ~mid ~src ~me ~fanout = + if SeenQ.mem mid seen then (* already seen *) + (View.empty, seen) + else + let dsts = + let d = Node.compare me src in + let fanout_rnd = + if d = 0 then fanout - 2 (* msg from self *) + else fanout - 1 in + let dsts = View.random_subset fanout_rnd view in + if 0 < d then (* msg from successor, fwd to predecessor *) + let dst = predecessor ~view ~dst:me in + match dst with + | Some node -> View.add node dsts + | _ -> dsts + else if d < 0 then (* msg from predecessor fwd to successor *) + let dst = successor ~view ~dst:me in + match dst with + | Some node -> View.add node dsts + | _ -> dsts + else (* msg from self, fwd to both successor & predecessor *) + let pnode = predecessor ~view ~dst:me in + let snode = successor ~view ~dst:me in + let dsts = + match pnode with + | Some node -> View.add node dsts + | _ -> dsts in + match snode with + | Some node -> View.add node dsts + | _ -> dsts in + let seen = + SeenQ.trim @@ + SeenQ.add mid 1 seen in + (dsts, seen) + +end + +(** Signatures *) +module S = S diff --git a/lib/p2p-ringcast/s.ml b/lib/p2p-ringcast/s.ml new file mode 100644 index 0000000..93a2570 --- /dev/null +++ b/lib/p2p-ringcast/s.ml @@ -0,0 +1,53 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +module type DISSEMINATION = sig + type nid + type node + type view + type mid + type seen + + val init_seen : int -> seen + + val forward : + view : view + -> seen : seen + -> mid : mid + -> src : node + -> me : node + -> fanout : int + -> (view * seen) +end + +module type GOSSIP_DISSEM = sig + type nid + type node + type view + type mid + type seen + + include P2p.S.GOSSIP + with type node := node + and type view := view + + include DISSEMINATION + with type nid := nid + and type node := node + and type view := view + and type mid := mid + and type seen := seen +end diff --git a/lib/p2p-vicinity-lwt/dune b/lib/p2p-vicinity-lwt/dune new file mode 100644 index 0000000..6665b23 --- /dev/null +++ b/lib/p2p-vicinity-lwt/dune @@ -0,0 +1,5 @@ +(library + (name p2p_vicinity_lwt) + (public_name p2p-vicinity-lwt) + (libraries p2p p2p-vicinity lwt lwt.unix) + (preprocess (pps lwt_ppx))) diff --git a/lib/p2p-vicinity-lwt/p2p_vicinity_lwt.ml b/lib/p2p-vicinity-lwt/p2p_vicinity_lwt.ml new file mode 100644 index 0000000..aa808b9 --- /dev/null +++ b/lib/p2p-vicinity-lwt/p2p_vicinity_lwt.ml @@ -0,0 +1,143 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +(** +{1 VICINITY with Lwt} + +High-level library implementing the VICINITY protocol using Lwt. +*) + +(** Functor building an implementation of Vicinity with Lwt + given a [Node_id], [Node], gossip [View], [Vicinity] implementation, + and an [Io] event handler module. *) +module Make + (Node_id : P2p.S.NODE_ID) + (Node : P2p.S.NODE with type nid := Node_id.t) + (View : P2p.S.VIEW with type nid := Node_id.t + and type node := Node.t) + (Vicinity : P2p.S.GOSSIP with type node := Node.t + and type view := View.t) + (Io : S.VICINITY_IO with type nid := Node_id.t + and type node := Node.t + and type view := View.t) + : S.VICINITY with type nid := Node_id.t + and type node := Node.t + and type view := View.t + and type io := Io.t = struct + + module Gossip = Vicinity + + type t = { + me : Node.t; (** this node *) + mutable view : View.t; (** partial view of gossip protocol *) + view_len : int; (** max view length *) + xchg_len : int; (** max exchange length *) + period : float; (** gossip period in seconds *) + io : Io.t; + mutable stop : unit Lwt.t option; + mutable stopper : unit Lwt.u option; + } + + let init ~me ~view ~view_len ~xchg_len ~period ~io = + { me; view; view_len; xchg_len; period; io; + stop = None; stopper = None } + + let view t = t.view + + (** wait for [delay] seconds, + then return the result of thread [t], + or cancel it if not finished yet **) + let timeout delay stop t = + let%lwt _ = Lwt.choose [ Lwt_unix.sleep delay; stop ] in + match Lwt.state t with + | Lwt.Sleep -> Lwt.cancel t; Lwt.return None + | Lwt.Return v -> Lwt.return (Some v) + | Lwt.Fail ex -> Lwt.fail ex + + (** initiate exchange with a node from [t.view], + wait for response, and return merged view *) + let initiate t dst sent view = + match dst with + | (Some dst) -> + let%lwt recvd = Io.initiate_gossip t.io dst sent in + let%lwt recvd = Io.gossip_recvd t.io dst recvd t.view in + t.view <- Gossip.merge ~view ~view_len:t.view_len ~me:t.me + ~sent ~recvd ~xchg_len:t.xchg_len; + let%lwt _ = Io.view_updated t.io t.me t.view in + Lwt.return t.view + | _ -> + Lwt.return t.view + + (** run initiator: pick a random node from [t.view] to gossip with + every [t.period] seconds *) + let run ?stop t = + match t.stop with + | Some stop -> stop + | None -> + let stop = + match stop with + | None -> + let (stop, stopper) = Lwt.wait () in + t.stopper <- Some stopper; + t.stop <- Some stop; + stop + | Some stop -> + t.stop <- Some stop; + stop in + + let rec loop () = + let xview = Io.get_xview t.io in + let (dst, sent, view_before) = + Gossip.initiate ~me:t.me ~view:t.view ~xview + ~xchg_len:t.xchg_len in + let%lwt view_after = timeout t.period stop + (initiate t dst sent view_before) in + let _ = t.view <- match view_after with + | Some v -> v + | _ -> view_before in + match Lwt.state stop with + | Lwt.Sleep -> loop () + | _ -> Lwt.return_unit + in loop () + + let shutdown t = + match t.stopper with + | Some stopper -> + Lwt.wakeup_later stopper (); + t.stop <- None; + t.stopper <- None + | None -> + match t.stop with + | Some stop -> + Lwt.cancel stop; + t.stop <- None + | None -> () + + (** merge received entries from a node and send response *) + let respond t src recvd = + let xview = Io.get_xview t.io in + let sent = Gossip.respond ~view:t.view ~xview + ~recvd ~src ~me:t.me ~xchg_len:t.xchg_len in + let%lwt _ = Io.respond_gossip t.io src sent in + let%lwt recvd = Io.gossip_recvd t.io src recvd t.view in + t.view <- Gossip.merge ~view:t.view ~view_len:t.view_len + ~sent ~recvd ~xchg_len:t.xchg_len ~me:t.me; + Lwt.return t.view + +end + +(** Signatures *) +module S = S diff --git a/lib/p2p-vicinity-lwt/s.ml b/lib/p2p-vicinity-lwt/s.ml new file mode 100644 index 0000000..e9ec3c5 --- /dev/null +++ b/lib/p2p-vicinity-lwt/s.ml @@ -0,0 +1,89 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +(** Type of a module implementing Vicinity using Lwt *) +module type VICINITY = sig + type t + type nid + type node + type view + type io + + val init : me:node -> view:view -> view_len:int -> xchg_len:int + -> period:float -> io:io -> t + (** [init node view view_len xchg_len period] + initializes a VICINITY instance with the following configuration: + - [my_node] - this node + - [view] - initial view + - [view_len] - max view length + - [xchg_len] - number of entries to exchange at each period + - [period] - gossip period, in seconds + *) + + val run : ?stop:unit Lwt.t -> t -> unit Lwt.t + (** [run t] runs initiator thread: + picks a random node from [view] to gossip with + every [period] seconds. + + If [?stop] is provided, this initiator thread returns + as soon as the [stop] thread is fulfilled. *) + + val shutdown : t -> unit + (** [shutdown t] stops initiator thread. + + In case [run] was called with a [stop] argument, + the [stop] thread is cancelled, otherwise it is fulfilled. *) + + val respond : t -> node -> view -> view Lwt.t + (** [respond t src recvd] + merges received entries from a node and sends response *) + + val view : t -> view + (** [view t] returns current view *) +end + +(** Type of a module implementing network I/O + and event handlers for {! VICINITY} *) +module type VICINITY_IO = sig + type t + type nid + type node + type view + + val initiate_gossip : t -> node -> view -> view Lwt.t + (** [initiate_gossip t dst xchg] + sends [xchg] entries to [node] + and returns response *) + + val respond_gossip : t -> node -> view -> unit Lwt.t + (** [respond_gossip t src xchg] + sends [xchg] entries in response to [node] *) + + val gossip_recvd : t -> node -> view -> view -> view Lwt.t + (** [gossip_recvd t src recvd view] + is called after entries are received during an exchange; + allows rewriting [recvd] entries with the returned value. *) + + val view_updated : t -> node -> view -> unit Lwt.t + (** [view_updated node view] + is called when [view] has been updated + after a gossip exchange with [node] *) + + val get_xview : t -> view + (** [get_xview t] + is called before selecting entries for a gossip exchange + and should return the view of other gossip protocol(s), if any. *) +end diff --git a/lib/p2p-vicinity/dune b/lib/p2p-vicinity/dune new file mode 100644 index 0000000..4c9fdb5 --- /dev/null +++ b/lib/p2p-vicinity/dune @@ -0,0 +1,4 @@ +(library + (name p2p_vicinity) + (public_name p2p-vicinity) + (libraries p2p)) diff --git a/lib/p2p-vicinity/p2p_vicinity.ml b/lib/p2p-vicinity/p2p_vicinity.ml new file mode 100644 index 0000000..76285a5 --- /dev/null +++ b/lib/p2p-vicinity/p2p_vicinity.ml @@ -0,0 +1,100 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +(** +{1 VICINITY: P2P topology management protocol} + +This is an implementation of VICINITY, a P2P topology management protocol +described in the paper {{:https://hal.inria.fr/hal-01480790/document} +VICINITY: A Pinch of Randomness Brings out the Structure}. +The protocol takes care of overlay construction & maintenance, +and can be used for e.g. clustering nodes in groups +or organizing them in a coordinate system. +*) + +(** Functor building an implementation of Vicinity + given a [Node_id], [Node], and gossip [View]. *) +module Make + (Node_id : P2p.S.NODE_ID) + (Node : S.NODE with type nid := Node_id.t) + (View : P2p.S.VIEW with type nid := Node_id.t + and type node := Node.t) + : P2p.S.GOSSIP with type node := Node.t + and type view := View.t = struct + + module Rng = Nocrypto.Rng + + type s = + { + sim: float; (** similarity measure *) + node: Node.t; + } + + (** select [xchg_len] nodes closest to [dst] from [view] *) + let closest ~view ~dst ~xchg_len = + let dlist = + List.stable_sort + (fun a b -> + if a.sim = b.sim then 0 + else if a.sim < b.sim then -1 + else 1) + (List.sort + (fun _a _b -> if Rng.Int.gen 2 = 0 then 1 else -1) + (View.fold + (fun _nid node lst -> + { node; sim = Node.sim dst node } :: lst) + view [])) in + List.fold_left + (fun dview dnode -> + if View.length dview < xchg_len + then View.add dnode.node dview + else dview) + View.empty + dlist + + let initiate ~view ~xview ~me ~xchg_len = + let dst = View.oldest view in + match dst with + | Some dst -> + let view = View.remove (Node.id dst) view in + let view = View.incr_age view in + let uview = View.union view xview in + let xchg_len = xchg_len - 1 in + let xchg = closest ~dst:me ~xchg_len ~view:uview in + let xchg = View.add me xchg in + (Some dst, xchg, view) + | None -> + (None, View.empty, view) + + let respond ~view ~xview ~recvd ~src ~me ~xchg_len = + let uview = View.add me view in + let uview = View.union uview xview in + let uview = View.filter (* remove recvd nodes *) + (fun nid _node -> not (View.mem nid recvd)) + uview in + closest ~dst:src ~xchg_len ~view:uview + + let merge ~view ~view_len ~sent ~recvd ~xchg_len ~me = + let _sent = sent in + let recvd = View.remove (Node.id me) recvd in + let recvd = View.random_subset xchg_len recvd in + let recvd = View.zero_age recvd in + let uview = View.union view recvd in + closest ~dst:me ~xchg_len:view_len ~view:uview +end + +(** Signatures *) +module S = S diff --git a/lib/p2p-vicinity/s.ml b/lib/p2p-vicinity/s.ml new file mode 100644 index 0000000..7ed4bc7 --- /dev/null +++ b/lib/p2p-vicinity/s.ml @@ -0,0 +1,24 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +(** Node *) +module type NODE = sig + + include P2p.S.NODE + + (** Similarity measure *) + val sim : t -> t -> float +end diff --git a/lib/p2p/dune b/lib/p2p/dune new file mode 100644 index 0000000..f9c5fd7 --- /dev/null +++ b/lib/p2p/dune @@ -0,0 +1,4 @@ +(library + (name p2p) + (public_name p2p) + (libraries fmt nocrypto stdint)) diff --git a/lib/p2p/group.ml b/lib/p2p/group.ml new file mode 100644 index 0000000..df4272c --- /dev/null +++ b/lib/p2p/group.ml @@ -0,0 +1,37 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +module Make + (Group_id : S.GROUP_ID) + : S.GROUP with type gid := Group_id.t = struct + + type gid = Group_id.t + + type t = { + id : gid; + } + + let init id = { id } + + let id t = t.id + + let compare a b = + Group_id.compare a.id b.id + + let pp ppf t = + Fmt.pf ppf "%a" Group_id.pp t.id + +end diff --git a/lib/p2p/group_id.ml b/lib/p2p/group_id.ml new file mode 100644 index 0000000..005ffb5 --- /dev/null +++ b/lib/p2p/group_id.ml @@ -0,0 +1,17 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +include Node_id diff --git a/lib/p2p/msg_id.ml b/lib/p2p/msg_id.ml new file mode 100644 index 0000000..005ffb5 --- /dev/null +++ b/lib/p2p/msg_id.ml @@ -0,0 +1,17 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +include Node_id diff --git a/lib/p2p/node.ml b/lib/p2p/node.ml new file mode 100644 index 0000000..8b28b60 --- /dev/null +++ b/lib/p2p/node.ml @@ -0,0 +1,68 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +module Make + (Node_id : S.NODE_ID) + : S.NODE with type nid := Node_id.t = struct + + type nid = Node_id.t + + type t = { + id : nid; + age : int; + ver : int; + } + + let id t = t.id + let age t = t.age + let ver t = t.ver + + let init ?(age=0) ?(ver=0) id = + { id; age; ver } + + let compare a b = + Node_id.compare a.id b.id + + let distance a b = + Node_id.distance a.id b.id + + let distance_ring a b = + Node_id.distance_ring a.id b.id + + let zero_age t = + { t with age = 0 } + + let incr_age t = + { t with age = t.age + 1 } + + let set_age t age = + { t with age } + + let incr_ver t = + { t with ver = t.ver + 1 } + + let set_ver t ver = + { t with ver } + + let to_string t = + Printf.sprintf "%s (ver: %d; age: %d)" + (Node_id.to_string t.id) t.ver t.age + + let pp ppf t = + Fmt.pf ppf "%s (ver: %d; age: %d)\n" + (Node_id.to_string t.id) t.ver t.age + +end diff --git a/lib/p2p/node_id.ml b/lib/p2p/node_id.ml new file mode 100644 index 0000000..c17ba62 --- /dev/null +++ b/lib/p2p/node_id.ml @@ -0,0 +1,57 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +open Stdint +open Uint64 + +type t = Uint64.t + +let zero = Uint64.zero +let one = Uint64.one + +let random () = + let open Int64 in + let r1 = Nocrypto.Rng.Int64.gen max_int in + let r2 = Nocrypto.Rng.Int64.gen max_int in + let open Uint64 in + of_int64 r1 + of_int64 r2 + +let compare a b = + if a = b then 0 + else if a < b then -1 + else 1 + +let distance a b = + abs @@ a - b + +let distance_ring a b = + let d = abs (a - b) in + if d = zero + then (0, d) + else + let d = if d <= (max_int - min_int) / (of_int 2) + then d + else max_int + one - d in + if (a - b = d) + then (-1, d) + else (1, d) + +let to_uint64 t = t + +let to_string = Uint64.to_string + +let pp ppf t = + Fmt.pf ppf "%s" @@ Uint64.to_string t diff --git a/lib/p2p/s.ml b/lib/p2p/s.ml new file mode 100644 index 0000000..91fe6c0 --- /dev/null +++ b/lib/p2p/s.ml @@ -0,0 +1,399 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +(** Node ID *) +module type NODE_ID = sig + type t + + val zero : t + (** [zero] returns node ID 0 *) + + val one : t + (** [one] returns node ID 1 *) + + val random : unit -> t + (** [random] returns a random node ID. *) + + val compare : t -> t -> int + (** [compare a b] compares node IDs [a] & [b]. + @return + - [0] if a = b + - [-1] if [a] < [b] + - [1] if [b] < [a] *) + + val distance : t -> t -> t + (** [distance a b] calculates distance between node IDs [a] & [b]. *) + + val distance_ring : t -> t -> (int * t) + (** [distance_ring a b] calculates distance between node IDs [a] & [b]. *) + + val to_uint64 : t -> Stdint.Uint64.t + (** [to_uint64 t] returns a uint64 representation of node ID [t] *) + + val to_string : t -> string + (** [to_string t] returns a string representation of node ID [t] *) + + val pp : Format.formatter -> t -> unit + (** [pp fmt t] pretty-prints node ID [t] *) +end + +(** Group ID *) +module type GROUP_ID = sig + type t + + val compare : t -> t -> int + (** [compare a b] compares group IDs [a] & [b]. + @return + - [0] if a = b + - [-1] if [a] < [b] + - [1] if [b] < [a] *) + + val to_string : t -> string + (** [to_string t] returns a string representation of group ID [t] *) + + val pp : Format.formatter -> t -> unit + (** [pp fmt t] pretty-prints group ID [t] *) +end + +(** Message ID *) +module type MSG_ID = sig + type t + + val compare : t -> t -> int + (** [compare a b] compares message IDs [a] & [b]. + @return + - [0] if a = b + - [-1] if [a] < [b] + - [1] if [b] < [a] *) + + val to_string : t -> string + (** [to_string t] returns a string representation of message ID [t] *) + + val pp : Format.formatter -> t -> unit + (** [pp fmt t] pretty-prints message ID [t] *) +end + +(** Node *) +module type NODE = sig + type t + type nid + + val init : ?age:int -> ?ver:int -> nid -> t + (** [init ?age ?ver nid] *) + + val id : t -> nid + (** [id t] returns ID of node [t] *) + + val age : t -> int + (** [age t] returns ID of node profile [t] *) + + val ver : t -> int + (** [ver t] returns version of node profile [t] *) + + val compare : t -> t -> int + (** [compare a b] compares IDs of nodes [a] & [b]. + See {! Node_id.compare} *) + + val distance : t -> t -> nid + (** [distance a b] calculates distance between IDs of nodes [a] & [b]. + See {! Node_id.distance} *) + + val distance_ring : t -> t -> (int * nid) + (** [distance_ring a b] calculates distance on a ring + between IDs of nodes [a] & [b]. + See {! Node_id.distance_ring} *) + + val zero_age : t -> t + (** [zero_age t] sets the age of node profile to zero. *) + + val set_age : t -> int -> t + (** [set_age t] sets the age of node profile to [age]. *) + + val incr_age : t -> t + (** [incr_age t] increments the age of node profile. *) + + val set_ver : t -> int -> t + (** [set_ver t] sets the version of node profile to [ver]. *) + + val incr_ver : t -> t + (** [incr_ver t] increments the version of node profile. *) + + val to_string : t -> string + (** [to_string t] returns a string representation of node [t] *) + + val pp : Format.formatter -> t -> unit + (** [pp fmt t] pretty-prints node [t] *) +end + +(** Group *) +module type GROUP = sig + type t + type gid + (* type node *) + + val init : gid -> t + (** [init gid] initializes a group with ID [gid]. *) + + val id : t -> gid + (** [id t] returns the ID of group [t]. *) + + val compare : t -> t -> int + (** [compare a b] compares IDs of groups [a] & [b]. + See {! Group_id.compare} *) + + val pp : Format.formatter -> t -> unit + (** [pp fmt t] pretty-prints group [t] *) +end + +(** Gossip view *) +module type VIEW = sig + type t + type nid + type node + + val empty : t + (** [empty] is the empty view. *) + + val add : node -> t -> t + (** [add node t] adds [node] to view [t] *) + + val remove : nid -> t -> t + (** [remove node t] removes [node] from view [t] *) + + val length : t -> int + (** [lengh t] returns the number of nodes in view [t] *) + + val is_empty : t -> bool + (** [is_empty t] returns true if there are no nodes in view [t] *) + + val mem : nid -> t -> bool + (** [mem nid t] returns true if [nid] is in view [t]. *) + + val find : nid -> t -> node option + (** [find nid t] returns [Some node] if [nid] is in view [t], + otherwise [None]. *) + + val oldest : t -> node option + (** [oldest t] returns the oldest node in view. + In case there are multiple oldest nodes, picks a random one of those. *) + + val random : t -> node option + (** [random t] selects a random from view [t]. Returns [None] if [t] is empty. *) + + val random_subset : int -> t -> t + (** [random_subset n t] selects a random subset of view [t] with [n] elements. *) + + val union : t -> t -> t + (** [union a b] returns the union of views [a] & [b]. *) + + val zero_age : t -> t + (** [zero_age t] sets the age of all nodes in view to 0. *) + + val incr_age : t -> t + (** [incr_age t] increments the age of all nodes in view. *) + + val filter : (nid -> node -> bool) -> t -> t + val fold : (nid -> node -> 'a -> 'a) -> t -> 'a -> 'a + val iter : (nid -> node -> unit) -> t -> unit + val map : (nid -> node -> node) -> t -> t + + val to_list : t -> node list + val of_list : node list -> t + + val pp : Format.formatter -> t -> unit + (** [pp ppf t] pretty-prints view [t] *) +end + +(** Gossip protocol *) +module type GOSSIP = sig + type node + type view + + val initiate : + view : view + -> xview : view + -> me : node + -> xchg_len : int + -> (node option * view * view) + (** [initiate ~view ~xview ~me ~xchg_len ?distance] + initiates gossip exchange. + + @param ~view current view + @param ~xview external view from another gossip protocol + @param ~me this node + @param ~xchg_len number of items in gossip exchange + + @return [(Some dst, xchg, view)]: + @param dst destination node + @param xchg items to send to [dst] + @param view updated view of this node*) + + val respond : + view : view + -> xview : view + -> recvd : view + -> src : node + -> me : node + -> xchg_len : int + -> view + (** [respond ~view ~xview ~recvd ~src ~me ~xchg_len] + responds to a gossip exchange. + + @param ~view current view + @param ~xview external view from another gossip protocol + @param ~recvd received items + @param ~src source node + @param ~me this node + @param ~xchg_len number of items in gossip exchange + + @return updated view *) + + val merge : + view : view + -> view_len : int + -> sent : view + -> recvd : view + -> xchg_len : int + -> me : node + -> view + (** [merge ~view ~view_len ~sent ~recvd ~xchg_len ~me] + merges received entries during a gossip exchange. + + @param ~view current view + @param ~view_len number of items in [view] + @param ~sent sent items + @param ~recvd received items + @param ~xchg_len number of items in gossip exchange + @param ~me this node + + @return updated view *) +end + +(** Dissemination of messages within a group *) +module type DISSEMINATION = sig + type nid + type node + type view + type mid + type seen + + val init_seen : int -> seen + (** [init_seen len] initializes the queue of last seen messages + with maximum queue length [len]. *) + + val forward : + view : view + -> seen : seen + -> mid : mid + -> src : node + -> me : node + -> fanout : int + -> (view * seen) + (** Select recipients to forward an incoming or outgoing message. + If [mid] was already [seen] before, the message is not fowarded. + + @param ~view Current view. + @param ~seen Queue of last seen message IDs. + @param ~mid Message ID. + @param ~src Source node. + @param ~fanout Number of nodes to select for forwarding. + + @return [(dsts, seen)] + @param dsts The list of destinations to forward to. + @param seen Updated seen queue with [mid] added. + *) +end + +(** Gossip + Dissemination combined *) +module type GOSSIP_DISSEM = sig + type nid + type node + type view + type mid + type seen + + include GOSSIP + with type node := node + and type view := view + + include DISSEMINATION + with type nid := nid + and type node := node + and type view := view + and type mid := mid + and type seen := seen +end + +(** Subscriptions of this node to groups *) +module type SUBSCRIPTION = sig + type 'a t + type gid + type group + + val empty : 'a t + (** [empty] returns the empty subscription set. *) + + val add : group -> 'a -> 'a t -> 'a t + (** [add group 'a t] adds group to the subscription set [t] *) + + val remove : gid -> 'a t -> 'a t + (** [remove group t] removes group from the subscription set [t] *) + + val length : 'a t -> int + (** [length t] returns the number of groups in the subscription set. *) + + val is_empty : 'a t -> bool + (** [is_empty t] returns true if the subscription set is empty. *) + + val mem : gid -> 'a t -> bool + (** [mem gid t] returns true if [gid] is in the subscription set. *) + + val find : gid -> 'a t -> (group * 'a) option + (** [find gid t] returns [Some group] if [gid] is in the subscription set, + otherwise [None]. *) + + val filter : (gid -> (group * 'a) -> bool) -> 'a t -> 'a t + val fold : (gid -> (group * 'a) -> 'b -> 'b) -> 'a t -> 'b -> 'b + val iter : (gid -> (group * 'a) -> unit) -> 'a t -> unit + val map : (gid -> (group * 'a) -> (group * 'a)) -> 'a t -> 'a t + + val to_list : 'a t -> (group * 'a) list + (** [to_list t] returns the subscription set as list ordered by group ID. *) +end + +(** Publish-subscribe message dissemination *) +module type PUBSUB = sig + type nid + type node + type view + type mid + type gid + type group + + module Pub : sig + include GOSSIP_DISSEM + with type nid := nid + and type node := node + and type view := view + and type mid := mid + end + + module Sub : sig + include SUBSCRIPTION + with type gid := gid + and type group := group + end +end diff --git a/lib/p2p/view.ml b/lib/p2p/view.ml new file mode 100644 index 0000000..6b297fb --- /dev/null +++ b/lib/p2p/view.ml @@ -0,0 +1,157 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +(** View *) + +module Rng = Nocrypto.Rng + +module Make + (Node_id: S.NODE_ID) + (Node : S.NODE with type nid := Node_id.t) + : S.VIEW with type nid := Node_id.t + and type node := Node.t = struct + + module I = struct + type t = int + let compare (a: int) b = compare a b + end + + module IntSet = Set.Make(I) + + module View = Map.Make(Node_id) + + type t = Node.t View.t + + let empty = View.empty + + let add node t = + let nid = Node.id node in + View.add nid node t + + let remove = View.remove + + let length = View.cardinal + let is_empty = View.is_empty + + let zero_age t = + View.map + (fun node -> Node.zero_age node) + t + + let incr_age t = + View.map + (fun node -> Node.incr_age node) + t + + (** get oldest node from [view], + in case there are multiple oldest nodes pick a random one + + returns [Some (nid, node)] or [None] if [view] is empty *) + let oldest t = + match + View.fold + (fun nid node oldest -> + match oldest with + | None -> + Some (nid, node, 1) + | Some (_onid, onode, _n) when (Node.age onode) < (Node.age node) -> + Some (nid, node, 1) + | Some (onid, onode, n) when (Node.age onode) = (Node.age node) -> + let n = n + 1 in + let max = 1000 in + if float_of_int (Rng.Int.gen max) /. float_of_int max + < 1. /. float_of_int n + then Some (nid, node, n) + else Some (onid, onode, n) + | _ -> oldest) + t None + with + | Some (_nid, node, _n) -> Some node + | None -> None + + let mem = View.mem + let find = View.find_opt + + (** get a random node from [view] *) + let random t = + let len = length t in + if 0 < len then + let r = Rng.Int.gen len in + let (rnode, _) = + View.fold + (fun _nid node a -> + let (rnode, n) = a in + if (n = r) + then (Some node, n + 1) + else (rnode, n + 1)) + t + (None, 0) + in + rnode + else + None + + (** return [len] random nodes from [view] *) + let random_subset len t = + if len < length t then + begin + let rset = + let rec add_rnd rset = + if IntSet.cardinal rset < len + then add_rnd @@ IntSet.add (Rng.Int.gen len) rset + else rset + in + add_rnd IntSet.empty in + let (rview, _) = + View.fold + (fun _nid node a -> + let (rview, n) = a in + if IntSet.mem n rset + then (add node rview, n + 1) + else (rview, n + 1)) + t + (empty, 0) in + rview + end + else t + + let union t1 t2 = + View.union + (fun _nid node1 node2 -> + if (Node.ver node1) < (Node.ver node2) + then Some node2 + else Some node1) + t1 t2 + + let filter = View.filter + let fold = View.fold + let iter = View.iter + let map = View.mapi + + let to_list t = + List.map + (fun (_nid, node) -> node) + (View.bindings t) + + let of_list l = + List.fold_left + (fun t node -> + add node t) + empty l + + let pp ppf t = + View.iter (fun _nid node -> Fmt.pf ppf " - %a\n" Node.pp node) t +end diff --git a/p2p-cyclon-lwt.opam b/p2p-cyclon-lwt.opam new file mode 100644 index 0000000..0792354 --- /dev/null +++ b/p2p-cyclon-lwt.opam @@ -0,0 +1,27 @@ +opam-version: "2.0" +name: "p2p-cyclon-lwt" +synopsis: "CYCLON: Lwt threads running the protocol" +maintainer: "TG x Thoth <*@tg-x.net>" +authors: ["TG x Thoth <*@tg-x.net>"] +tags: [ "p2p" "protocol" "membership" "gossip" ] +license: "AGPL-3.0-only" +homepage: "https://p2pcollab.net" +doc: "https://p2pcollab.net/doc/ocaml/cyclon-lwt" +dev-repo: "git+https://github.com/p2pcollab/ocaml-p2p.git" +bug-reports: "https://github.com/p2pcollab/ocaml-p2p/issues" +depends: +[ + "dune" {build & >= "1.0.0"} + "lwt" + "lwt_ppx" + "p2p-cyclon" + "urps" {with-test} + "ounit" {with-test} +] +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] +] +run-test: [ + ["dune" "runtest" "-p" name "-j" jobs] +] diff --git a/p2p-cyclon.opam b/p2p-cyclon.opam new file mode 100644 index 0000000..d3395bc --- /dev/null +++ b/p2p-cyclon.opam @@ -0,0 +1,23 @@ +opam-version: "2.0" +name: "p2p-cyclon" +synopsis: "CYCLON: Inexpensive Membership Management for Unstructured P2P Overlays" +maintainer: "TG x Thoth <*@tg-x.net>" +authors: ["TG x Thoth <*@tg-x.net>"] +tags: [ "p2p" "protocol" "membership" "gossip" "cyclon" ] +license: "AGPL-3.0-only" +homepage: "https://p2pcollab.net" +doc: "https://p2pcollab.net/doc/ocaml/cyclon" +dev-repo: "git+https://github.com/p2pcollab/ocaml-p2p.git" +bug-reports: "https://github.com/p2pcollab/ocaml-p2p/issues" +depends: +[ + "dune" {build & >= "1.0.0"} + "ounit" {with-test} +] +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] +] +run-test: [ + ["dune" "runtest" "-p" name "-j" jobs] +] diff --git a/p2p-poldercast-lwt.opam b/p2p-poldercast-lwt.opam new file mode 100644 index 0000000..5ab5e20 --- /dev/null +++ b/p2p-poldercast-lwt.opam @@ -0,0 +1,26 @@ +opam-version: "2.0" +name: "poldercast-lwt" +synopsis: "RingCast: Lwt threads running the protocol" +maintainer: "TG x Thoth <*@tg-x.net>" +authors: ["TG x Thoth <*@tg-x.net>"] +tags: [ "p2p" "multicast" "protocol" "ring" ] +license: "AGPL-3.0-only" +homepage: "https://p2pcollab.net" +doc: "https://p2pcollab.net/doc/ocaml/poldercast-lwt" +dev-repo: "git+https://github.com/p2pcollab/ocaml-poldercast.git" +bug-reports: "https://github.com/p2pcollab/ocaml-poldercast/issues" +depends: +[ + "dune" {build & >= "1.0.0"} + "poldercast" + "lwt" + "lwt_ppx" + "ounit" {with-test} +] +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] +] +run-test: [ + ["dune" "runtest" "-p" name "-j" jobs] +] diff --git a/p2p-poldercast.opam b/p2p-poldercast.opam new file mode 100644 index 0000000..d58de23 --- /dev/null +++ b/p2p-poldercast.opam @@ -0,0 +1,24 @@ +opam-version: "2.0" +name: "p2p-poldercast" +synopsis: "PolderCast: P2P hybrid (probabilistic/deterministic) dissemination" +maintainer: "TG x Thoth <*@tg-x.net>" +authors: ["TG x Thoth <*@tg-x.net>"] +tags: [ "p2p" "multicast" "protocol" "ring" ] +license: "AGPL-3.0-only" +homepage: "https://p2pcollab.net" +doc: "https://p2pcollab.net/doc/ocaml/poldercast" +dev-repo: "git+https://github.com/p2pcollab/ocaml-p2p.git" +bug-reports: "https://github.com/p2pcollab/ocaml-p2p/issues" +depends: +[ + "dune" {build & >= "1.0.0"} + "ounit" {with-test} + "psq" +] +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] +] +run-test: [ + ["dune" "runtest" "-p" name "-j" jobs] +] diff --git a/p2p-ringcast-lwt.opam b/p2p-ringcast-lwt.opam new file mode 100644 index 0000000..1672bc9 --- /dev/null +++ b/p2p-ringcast-lwt.opam @@ -0,0 +1,26 @@ +opam-version: "2.0" +name: "ringcast-lwt" +synopsis: "RingCast: Lwt threads running the protocol" +maintainer: "TG x Thoth <*@tg-x.net>" +authors: ["TG x Thoth <*@tg-x.net>"] +tags: [ "p2p" "multicast" "protocol" "ring" ] +license: "AGPL-3.0-only" +homepage: "https://p2pcollab.net" +doc: "https://p2pcollab.net/doc/ocaml/ringcast-lwt" +dev-repo: "git+https://github.com/p2pcollab/ocaml-p2p.git" +bug-reports: "https://github.com/p2pcollab/ocaml-p2p/issues" +depends: +[ + "dune" {build & >= "1.0.0"} + "ringcast" + "lwt" + "lwt_ppx" + "ounit" {with-test} +] +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] +] +run-test: [ + ["dune" "runtest" "-p" name "-j" jobs] +] diff --git a/p2p-ringcast.opam b/p2p-ringcast.opam new file mode 100644 index 0000000..7954ac4 --- /dev/null +++ b/p2p-ringcast.opam @@ -0,0 +1,25 @@ +opam-version: "2.0" +name: "p2p-ringcast" +synopsis: "RingCast: P2P hybrid (probabilistic/deterministic) dissemination" +maintainer: "TG x Thoth <*@tg-x.net>" +authors: ["TG x Thoth <*@tg-x.net>"] +tags: [ "p2p" "multicast" "protocol" "ring" ] +license: "AGPL-3.0-only" +homepage: "https://p2pcollab.net" +doc: "https://p2pcollab.net/doc/ocaml/ringcast" +dev-repo: "git+https://github.com/p2pcollab/ocaml-p2p.git" +bug-reports: "https://github.com/p2pcollab/ocaml-p2p/issues" +depends: +[ + "dune" {build & >= "1.0.0"} + "ounit" {with-test} + "p2p" + "lru" +] +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] +] +run-test: [ + ["dune" "runtest" "-p" name "-j" jobs] +] diff --git a/p2p-vicinity-lwt.opam b/p2p-vicinity-lwt.opam new file mode 100644 index 0000000..abe2bc6 --- /dev/null +++ b/p2p-vicinity-lwt.opam @@ -0,0 +1,26 @@ +opam-version: "2.0" +name: "p2p-vicinity-lwt" +synopsis: "VICINITY: Lwt threads running the protocol" +maintainer: "TG x Thoth <*@tg-x.net>" +authors: ["TG x Thoth <*@tg-x.net>"] +tags: [ "p2p" "overlay" "topology" "management" "clustering" "protocol" ] +license: "AGPL-3.0-only" +homepage: "https://p2pcollab.net" +doc: "https://p2pcollab.net/doc/ocaml/vicinity-lwt" +dev-repo: "git+https://github.com/p2pcollab/ocaml-p2p.git" +bug-reports: "https://github.com/p2pcollab/ocaml-p2p/issues" +depends: +[ + "dune" {build & >= "1.0.0"} + "p2p-vicinity" + "lwt" + "lwt_ppx" + "ounit" {with-test} +] +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] +] +run-test: [ + ["dune" "runtest" "-p" name "-j" jobs] +] diff --git a/p2p-vicinity.opam b/p2p-vicinity.opam new file mode 100644 index 0000000..3c53273 --- /dev/null +++ b/p2p-vicinity.opam @@ -0,0 +1,23 @@ +opam-version: "2.0" +name: "p2p-vicinity" +synopsis: "VICINITY: P2P topology management & clustering protocol" +maintainer: "TG x Thoth <*@tg-x.net>" +authors: ["TG x Thoth <*@tg-x.net>"] +tags: [ "p2p" "overlay" "topology" "management" "clustering" "protocol" ] +license: "AGPL-3.0-only" +homepage: "https://p2pcollab.net" +doc: "https://p2pcollab.net/doc/ocaml/vicinity" +dev-repo: "git+https://github.com/p2pcollab/ocaml-p2p.git" +bug-reports: "https://github.com/p2pcollab/ocaml-p2p/issues" +depends: +[ + "dune" {build & >= "1.0.0"} + "ounit" {with-test} +] +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] +] +run-test: [ + ["dune" "runtest" "-p" name "-j" jobs] +] diff --git a/p2p.opam b/p2p.opam new file mode 100644 index 0000000..6df5ed1 --- /dev/null +++ b/p2p.opam @@ -0,0 +1,27 @@ +opam-version: "2.0" +name: "p2p" +synopsis: "Composable P2P network construction libraries" +maintainer: "TG x Thoth <*@tg-x.net>" +authors: ["TG x Thoth <*@tg-x.net>"] +tags: [ "p2p" "protocol" ] +license: "AGPL-3.0-only" +homepage: "https://p2pcollab.net" +doc: "https://p2pcollab.net/doc/ocaml/p2p" +dev-repo: "git+https://github.com/p2pcollab/ocaml-p2p.git" +bug-reports: "https://github.com/p2pcollab/ocaml-p2p/issues" +depends: +[ + "dune" {build & >= "1.0.0"} + "ounit" {with-test} + "fmt" + "fsq" + "nocrypto" + "stdint" +] +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] +] +run-test: [ + ["dune" "runtest" "-p" name "-j" jobs] +] diff --git a/test/p2p-cyclon-lwt/dune b/test/p2p-cyclon-lwt/dune new file mode 100644 index 0000000..5b37c29 --- /dev/null +++ b/test/p2p-cyclon-lwt/dune @@ -0,0 +1,15 @@ +(tests + (names test_cyclon_lwt) + (package p2p-cyclon-lwt) + (libraries + p2p-cyclon + p2p-cyclon-lwt + urps + lwt + oUnit + nocrypto.lwt + ) + (preprocess + (pps lwt_ppx) + ) +) diff --git a/test/p2p-cyclon-lwt/test_cyclon_lwt.ml b/test/p2p-cyclon-lwt/test_cyclon_lwt.ml new file mode 100644 index 0000000..3c47e51 --- /dev/null +++ b/test/p2p-cyclon-lwt/test_cyclon_lwt.ml @@ -0,0 +1,146 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +open Stdint + +let u64 = Uint64.of_int64 +let pf = Fmt.pf +let out = Fmt.stdout + +module Node_id = P2p.Node_id +module Node = P2p.Node.Make (Node_id) +module View = P2p.View.Make (Node_id) (Node) +module Cyclon = P2p_cyclon.Make (Node_id) (Node) (View) +module Sampler = Urps.Sampler.Make (Node_id) + +module Io = struct + + type t = { + node_id: Node_id.t; + sampler : Node.t Sampler.t; + in_chan : Lwt_io.input_channel; + out_chan : Lwt_io.output_channel; + } + + let init node_id in_chan out_chan = + let c = 700 in + let s = 10 in + let k = 50 in + let sampler = Sampler.init c s k in + { node_id; sampler; in_chan; out_chan } + + (** [initiate_gossip t node xchg] + sends [xchg] entries to node [dst] + and returns response *) + let initiate_gossip t dst xchg = + pf out "%a # INITIATE_GOSSIP to node %a\n" Node_id.pp t.node_id Node.pp dst; + pf out "xchg to send:\n%a\n" View.pp xchg; flush stdout; + flush stdout; + let%lwt _ = Lwt_io.write_value t.out_chan xchg in + Lwt_io.read_value t.in_chan + + (** [respond_gossip t node xchg] + sends [xchg] entries in response to node [dst] *) + let respond_gossip t dst xchg = + pf out "%a # RESPOND_GOSSIP to node %a\n" Node_id.pp t.node_id Node.pp dst; + pf out "xchg to send:\n%a\n" View.pp xchg; + flush stdout; + let%lwt _ = Lwt_io.write_value t.out_chan xchg in + Lwt.return_unit + + (** [gossip_recvd t view src recvd] + is called after entries are received from node [src] during a gossip exchange; + allows rewriting [recvd] entries with the returned value, + thus allows using a stream sampler such as URPS + to provide uniformly random nodes instead of the possibly biased exchanged nodes *) + let gossip_recvd t src recvd _view = + let sampled = + View.fold (fun nid node sampled -> + let (_id, n) = Sampler.add t.sampler nid node in + View.add n sampled) + recvd + View.empty in + pf out "%a # GOSSIP_RECVD from node %a\n" Node_id.pp t.node_id Node.pp src; + pf out "recvd:\n%a\n" View.pp recvd; + pf out "sampled:\n%a\n" View.pp sampled; + flush stdout; + Lwt.return sampled + + (** [view_updated node view] + is called when [view] has been updated after a gossip exchange *) + let view_updated t node view = + pf out "%a # VIEW_UPDATED of node %a\n%a\n" Node_id.pp t.node_id Node.pp node View.pp view; + flush stdout; + Lwt.return_unit +end + +module Cyclon_lwt = P2p_cyclon_lwt.Make (Node_id) (Node) (View) (Cyclon) (Io) + +let rec read_chan ch cy node rnode = + let%lwt recvd = Lwt_io.read_value ch in + pf out "%a # READ_CHAN\n" Node_id.pp (Node.id node); + pf out "recvd:\n%a\n" View.pp recvd; + flush stdout; + let%lwt view = Cyclon_lwt.respond cy rnode recvd in + pf out "recvd:\n%a\n" View.pp recvd; + pf out "view:\n%a\n" View.pp view; + flush stdout; + read_chan ch cy node rnode + +let _ = Nocrypto_entropy_lwt.initialize () + +let () = + let view_len = 8 in + let xchg_len = 4 in + let period = 1.0 in + + let (in_ch1, out_ch2) = Lwt_io.pipe () in + let (in_ch2, out_ch1) = Lwt_io.pipe () in + + let node1 = Node.init (u64 100L) in + let io1 = Io.init (Node.id node1) in_ch1 out_ch1 in + let view1 = + View.add (Node.init (u64 110L)) + (View.add (Node.init (u64 120L)) + (View.add (Node.init (u64 130L)) + (View.add (Node.init (u64 140L)) + (View.add (Node.init (u64 150L)) + (View.add (Node.init (u64 160L)) + (View.add (Node.init (u64 170L)) + View.empty)))))) in + let cyclon1 = Cyclon_lwt.init ~me:node1 ~view:view1 ~view_len ~xchg_len ~period ~io:io1 in + + let node2 = Node.init (u64 200L) in + let io2 = Io.init (Node.id node2) in_ch2 out_ch2 in + let view2 = + View.add (Node.init (u64 210L)) + (View.add (Node.init (u64 220L)) + (View.add (Node.init (u64 230L)) + (View.add (Node.init (u64 240L)) + (View.add (Node.init (u64 250L)) + (View.add (Node.init (u64 260L)) + (View.add (Node.init (u64 270L)) + View.empty)))))) in + let cyclon2 = Cyclon_lwt.init ~me:node2 ~view:view2 ~view_len ~xchg_len ~period ~io:io2 in + + let timeout = Lwt_unix.sleep 5.5 in + Lwt_main.run @@ + Lwt.choose [ Cyclon_lwt.run cyclon1; + Cyclon_lwt.run cyclon2; + read_chan in_ch1 cyclon1 node1 node2; + read_chan in_ch2 cyclon2 node2 node1; + Lwt.map (fun () -> Cyclon_lwt.shutdown cyclon1; + Cyclon_lwt.shutdown cyclon2) timeout ] diff --git a/test/p2p-cyclon/dune b/test/p2p-cyclon/dune new file mode 100644 index 0000000..0ca1a84 --- /dev/null +++ b/test/p2p-cyclon/dune @@ -0,0 +1,9 @@ +(test + (name test_cyclon) + (package p2p-cyclon) + (libraries + p2p-cyclon + oUnit + nocrypto.unix + ) +) diff --git a/test/p2p-cyclon/test_cyclon.ml b/test/p2p-cyclon/test_cyclon.ml new file mode 100644 index 0000000..bb8cc5d --- /dev/null +++ b/test/p2p-cyclon/test_cyclon.ml @@ -0,0 +1,80 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +open OUnit2 +open Printf +open Stdint + +module Node_id = P2p.Node_id +module Node = P2p.Node.Make (Node_id) +module View = P2p.View.Make (Node_id) (Node) +module Cyclon = P2p_cyclon.Make (Node_id) (Node) (View) + +let u64 = Uint64.of_int64 +let pf = Fmt.pf +let out = Fmt.stdout + +let view_len = 7 +let xchg_len = 3 +let me = Node.init (u64 99L) + +let my_view = + View.add (Node.init (u64 1L)) + (View.add (Node.init (u64 2L)) + (View.add (Node.init (u64 3L)) + (View.add (Node.init (u64 4L)) + (View.add (Node.init (u64 5L)) + (View.add (Node.init (u64 6L)) + (View.add (Node.init (u64 7L)) + View.empty)))))) + +let my_recvd = + View.add (Node.init (u64 10L)) + (View.add (Node.init (u64 20L)) + (View.add (Node.init (u64 3L)) + View.empty)) + +let test_gossip _ctx = + printf "\nCYCLON GOSSIP\n"; + let view = my_view in + let (dst, sent, view) = Cyclon.initiate ~me ~view ~xview:View.empty ~xchg_len in + let recvd = my_recvd in + let dst = + match dst with + | Some dst -> dst + | None -> assert_failure "No gossip target" in + pf out "Gossip target: %a\n" Node.pp dst; + pf out "Gossip sent (%d):\n%a\n" (View.length sent) View.pp sent; + pf out "Gossip received (%d):\n%a\n" (View.length recvd) View.pp recvd; + assert_equal (View.length sent) xchg_len; + pf out "View before gossip (%d):\n%a\n" (View.length view) View.pp view; + let view = Cyclon.merge ~me ~view ~view_len ~sent ~recvd ~xchg_len in + pf out "View after gossip (%d):\n%a\n" (View.length view) View.pp view; + assert_equal (View.length view) view_len; + assert_equal (View.mem (Node.id me) view) false; + let resp = Cyclon.respond ~view ~xview:View.empty ~recvd ~xchg_len ~src:me ~me in + pf out "Gossip response:\n%a\n" View.pp resp; + assert_equal (View.length resp) xchg_len + +let suite = + "suite">::: + [ + "gossip">:: test_gossip; + ] + +let () = + Nocrypto_entropy_unix.initialize (); + run_test_tt_main suite diff --git a/test/p2p-poldercast-lwt/dune b/test/p2p-poldercast-lwt/dune new file mode 100644 index 0000000..ffbe706 --- /dev/null +++ b/test/p2p-poldercast-lwt/dune @@ -0,0 +1,16 @@ +(tests + (names test_poldercast_lwt) + (package p2p-poldercast-lwt) + (libraries + p2p-ringcast + p2p-ringcast-lwt + p2p-poldercast + p2p-poldercast-lwt + lwt + oUnit + nocrypto.lwt + ) + (preprocess + (pps lwt_ppx) + ) +) diff --git a/test/p2p-poldercast-lwt/test_poldercast_lwt.ml b/test/p2p-poldercast-lwt/test_poldercast_lwt.ml new file mode 100644 index 0000000..9b490b3 --- /dev/null +++ b/test/p2p-poldercast-lwt/test_poldercast_lwt.ml @@ -0,0 +1,202 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +open OUnit2 +open Stdint + +module Node_id = P2p.Node_id +module Group_id = P2p.Group_id +module Node = P2p_poldercast.Node.Make (Node_id) +module Group = P2p.Group.Make (Group_id) +module View = P2p.View.Make (Node_id) (Node) +module Msg_id = P2p.Msg_id +module Ringcast = P2p_ringcast.Make (Node_id) (Node) (View) (Msg_id) +module Poldercast = P2p_poldercast.Make (Node_id) (Group_id) (Node) (Group) + (View) (Msg_id) (Ringcast) + +let u64 = Uint64.of_int64 +let pf = Fmt.pf +let out = Fmt.stdout +let sent_msgs = Hashtbl.create 3 + +(** union of views *) +module UView = struct + + type t = { + rings : (Group_id.t, View.t) Hashtbl.t; + } + + let create = + { rings = Hashtbl.create 10 } + + let set_ring t gid view = + Hashtbl.replace t.rings gid view + + let view t = + Hashtbl.fold + (fun _gid view uview -> + View.union uview view) + t.rings View.empty + +end + +module Io = struct + + module IoMap = Map.Make (Node) + + type t = { + group : Group.t; + me : Node.t; + uview : UView.t; + io : (Lwt_io.input_channel * Lwt_io.output_channel) IoMap.t; + } + + let init me uview = + (fun group -> + { group; me; uview; io = IoMap.empty }) + + let get_chan t dst = + match IoMap.find_opt dst t.io with + | None -> + let (in_chan, out_chan) = Lwt_io.pipe () in + (in_chan, out_chan) + | Some (in_chan, out_chan) -> + (in_chan, out_chan) + + let recv_gossip t group src xchg = + let (_in_chan, out_chan) = get_chan t src in + Lwt_io.write_value out_chan (group, xchg) + + let recv_msg t group src msg = + let (_in_chan, out_chan) = get_chan t src in + Lwt_io.write_value out_chan (group, msg) + + (** [initiate_gossip t node xchg] + sends [xchg] entries to node [dst] + and returns response *) + let initiate_gossip t dst xchg = + pf out "%a/%a # INITIATE_GOSSIP to node %a\n" + Group.pp t.group + Node.pp t.me + Node.pp dst; + pf out "xchg to send:\n%a\n" View.pp xchg; + flush stdout; + let (in_chan, out_chan) = get_chan t dst in + let%lwt _ = Lwt_io.write_value out_chan (t.group, xchg) in + let%lwt (rgroup, rxchg) = Lwt_io.read_value in_chan in + assert_equal t.group rgroup; + Lwt.return rxchg + + (** [respond_gossip t node xchg] + sends [xchg] entries in response to node [dst] *) + let respond_gossip t dst xchg = + pf out "%a/%a # RESPOND_GOSSIP to node %a\n" + Group.pp t.group + Node.pp t.me + Node.pp dst; + pf out "xchg to send:\n%a\n" View.pp xchg; + flush stdout; + let (_in_chan, out_chan) = get_chan t dst in + let%lwt _ = Lwt_io.write_value out_chan (t.group, xchg) in + Lwt.return_unit + + (** [gossip_recvd t node view recvd] + is called after entries are received during a gossip exchange; + allows rewriting [recvd] entries with the returned value. *) + let gossip_recvd _t _src recvd _view = + Lwt.return recvd + + (** [view_updated node view] + is called when [view] has been updated after a gossip exchange *) + let view_updated t node view = + pf out "%a/%a # VIEW_UPDATED of node %a\n%a\n" + Group.pp t.group + Node.pp t.me + Node.pp node + View.pp view; + flush stdout; + UView.set_ring t.uview (Group.id t.group) view; + Lwt.return_unit + + let send_msg t dst mid msg = + pf out "%a/%a # SEND_MSG %a to node %a%s\n" + Group.pp t.group + Node.pp t.me + Msg_id.pp mid + Node.pp dst + (Cstruct.to_string msg); + flush stdout; + let n = + match Hashtbl.find_opt sent_msgs mid with + | Some n -> n + | None -> 0 in + Hashtbl.add sent_msgs mid (n + 1); + Lwt.return_unit + + let get_xview t = + UView.view t.uview +end + +module Ringcast_lwt = + P2p_ringcast_lwt.Make (Node_id) (Node) (View) (Msg_id) (Ringcast) (Io) + +module Poldercast_lwt = + P2p_poldercast_lwt.Make (Node_id) (Group_id) (Node) (Group) (View) (Msg_id) + (Ringcast) (Io) (Ringcast_lwt) (Poldercast) + +let _ = Nocrypto_entropy_lwt.initialize () + +let () = + let view_len = 8 in + let xchg_len = 4 in + let period = 1.0 in + let fanout = 5 in + let seen_len = 10 in + + let me = Node.init (u64 100L) in + + let group1 = Group.init (u64 1000L) in + let view1 = + View.add (Node.init (u64 110L)) + (View.add (Node.init (u64 120L)) + (View.add (Node.init (u64 130L)) + (View.add (Node.init (u64 140L)) + (View.add (Node.init (u64 150L)) + (View.add (Node.init (u64 160L)) + (View.add (Node.init (u64 170L)) + View.empty)))))) in + + let group2 = Group.init (u64 2000L) in + let view2 = + View.add (Node.init (u64 210L)) + (View.add (Node.init (u64 220L)) + (View.add (Node.init (u64 230L)) + (View.add (Node.init (u64 240L)) + (View.add (Node.init (u64 250L)) + (View.add (Node.init (u64 260L)) + (View.add (Node.init (u64 270L)) + View.empty)))))) in + + let io = Io.init me UView.create in + let sub_list = [ (group1, view1); (group2, view2) ] in + let pc = Poldercast_lwt.init ~me ~view_len ~xchg_len + ~period ~fanout ~seen_len ~sub_list ~io + ?max_subs:None ?stop:None in + + let timeout = Lwt_unix.sleep 5.5 in + Lwt_main.run @@ + Lwt.choose [ Poldercast_lwt.run pc; + Lwt.map (fun () -> Poldercast_lwt.shutdown pc) timeout ]; diff --git a/test/p2p-poldercast/dune b/test/p2p-poldercast/dune new file mode 100644 index 0000000..26531ea --- /dev/null +++ b/test/p2p-poldercast/dune @@ -0,0 +1,11 @@ +(test + (name test_poldercast) + (package p2p-poldercast) + (libraries + p2p-ringcast + p2p-poldercast + oUnit + nocrypto.unix + bitv + ) +) diff --git a/test/p2p-poldercast/test_poldercast.ml b/test/p2p-poldercast/test_poldercast.ml new file mode 100644 index 0000000..7356252 --- /dev/null +++ b/test/p2p-poldercast/test_poldercast.ml @@ -0,0 +1,80 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +open OUnit2 +open Printf +open Stdint + +module Node_id = P2p.Node_id +module Group_id = P2p.Group_id +module Msg_id = P2p.Msg_id + +module Node = P2p_poldercast.Node.Make (Node_id) +module Group = P2p.Group.Make (Group_id) +module View = P2p.View.Make (Node_id) (Node) + +module Ringcast = P2p_ringcast.Make (Node_id) (Node) (View) (Msg_id) + +module Poldercast = P2p_poldercast.Make (Node_id) (Group_id) (Node) (Group) (View) (Msg_id) (Ringcast) +module Pub = Poldercast.Pub +module Sub = Poldercast.Sub + +let u64 = Uint64.of_int64 +let pf = Fmt.pf +let out = Fmt.stdout +let e = 10. + +let test_sub _ctx = + printf "\nPOLDERCAST SUB\n"; + let sub = Sub.add (Group.init (u64 11L)) () + (Sub.add (Group.init (u64 23L)) () + (Sub.add (Group.init (u64 37L)) () + (Sub.add (Group.init (u64 41L)) () + (Sub.empty)))) in + let n23 = Node.init (u64 23L) in + let _bits = Sub.bloom sub in + let blip = Sub.blip sub e in + let n23 = Node.set_subs n23 blip in + printf "n23:\n%s" (Node.to_string n23); + + let n42 = Node.init (u64 42L) in + let _bits = Sub.bloom sub in + let blip = Sub.blip sub e in + let n42 = Node.set_subs n42 blip in + printf "n42:\n%s" (Node.to_string n42); + + let sim = Node.sim n23 n23 in + assert_equal sim 1.; + let sim = Node.sim n23 n42 in + printf "sim n23 n42 = %.2f\n" sim; + + let g41 = (u64 41L) in + assert_equal (Sub.mem g41 sub) true; + assert_equal (Sub.length sub) 4; + + let sub = Sub.remove g41 sub in + assert_equal (Sub.mem g41 sub) false; + assert_equal (Sub.length sub) 3 + +let suite = + "suite">::: + [ + "sub">:: test_sub; + ] + +let () = + Nocrypto_entropy_unix.initialize (); + run_test_tt_main suite diff --git a/test/p2p-ringcast-lwt/dune b/test/p2p-ringcast-lwt/dune new file mode 100644 index 0000000..6e52111 --- /dev/null +++ b/test/p2p-ringcast-lwt/dune @@ -0,0 +1,14 @@ +(tests + (names test_ringcast_lwt) + (package p2p-ringcast-lwt) + (libraries + p2p-ringcast + p2p-ringcast-lwt + lwt + oUnit + nocrypto.lwt + ) + (preprocess + (pps lwt_ppx) + ) +) diff --git a/test/p2p-ringcast-lwt/test_ringcast_lwt.ml b/test/p2p-ringcast-lwt/test_ringcast_lwt.ml new file mode 100644 index 0000000..99920ed --- /dev/null +++ b/test/p2p-ringcast-lwt/test_ringcast_lwt.ml @@ -0,0 +1,182 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +open Stdint +open OUnit2 + +let u64 = Uint64.of_int64 +let pf = Fmt.pf +let out = Fmt.stdout +let sent_msgs = Hashtbl.create 3 + +module Node_id = P2p.Node_id +module Node = P2p.Node.Make (Node_id) +module View = P2p.View.Make (Node_id) (Node) +module Msg_id = P2p.Msg_id +module Ringcast = P2p_ringcast.Make (Node_id) (Node) (View) (Msg_id) + +module Io = struct + + type t = { + node_id: Node_id.t; + in_chan : Lwt_io.input_channel; + out_chan : Lwt_io.output_channel; + } + + let init node_id in_chan out_chan = + { node_id; in_chan; out_chan } + + (** [initiate_gossip t node xchg] + sends [xchg] entries to node [dst] + and returns response *) + let initiate_gossip t dst xchg = + pf out "%a # INITIATE_GOSSIP to node %a\n" Node_id.pp t.node_id Node.pp dst; + pf out "xchg to send:\n%a\n" View.pp xchg; + flush stdout; + let%lwt _ = Lwt_io.write_value t.out_chan xchg in + Lwt_io.read_value t.in_chan + + (** [respond_gossip t node xchg] + sends [xchg] entries in response to node [dst] *) + let respond_gossip t dst xchg = + pf out "%a # RESPOND_GOSSIP to node %a\n" Node_id.pp t.node_id Node.pp dst; + pf out "xchg to send:\n%a\n" View.pp xchg; + flush stdout; + let%lwt _ = Lwt_io.write_value t.out_chan xchg in + Lwt.return_unit + + (** [gossip_recvd t node view recvd] + is called after entries are received during a gossip exchange; + allows rewriting [recvd] entries with the returned value. *) + let gossip_recvd _t _src recvd _view = + Lwt.return recvd + + (** [view_updated node view] + is called when [view] has been updated after a gossip exchange *) + let view_updated t node view = + pf out "%a # VIEW_UPDATED of node %a\n%a\n" Node_id.pp t.node_id Node.pp node View.pp view; + flush stdout; + Lwt.return_unit + + let send_msg t dst mid msg = + pf out "%a # SEND_MSG %a to node %a%s\n" + Node_id.pp t.node_id + Msg_id.pp mid + Node.pp dst + (Cstruct.to_string msg); + flush stdout; + let n = + match Hashtbl.find_opt sent_msgs mid with + | Some n -> n + | None -> 0 in + Hashtbl.add sent_msgs mid (n + 1); + Lwt.return_unit + + let get_xview _t = + View.empty +end + +module Ringcast_lwt = + P2p_ringcast_lwt.Make (Node_id) (Node) (View) (Msg_id) (Ringcast) (Io) + +let rec read_chan ch rc node rnode = + let%lwt recvd = Lwt_io.read_value ch in + pf out "%a # READ_CHAN\n" Node_id.pp (Node.id node); + pf out "recvd:\n%a\n" View.pp recvd; + flush stdout; + let%lwt view = Ringcast_lwt.respond rc rnode recvd in + pf out "recvd:\n%a\n" View.pp recvd; + pf out "view:\n%a\n" View.pp view; + flush stdout; + read_chan ch rc node rnode + +let forward delay rc src msgid msg = + let%lwt _ = Lwt_unix.sleep delay in + Ringcast_lwt.forward rc src msgid (Cstruct.of_string msg) + +let check_sent_msgs delay = + let%lwt _ = Lwt_unix.sleep delay in + let s1, s2, s3 = + Hashtbl.find sent_msgs (Uint64.of_int 1), + Hashtbl.find sent_msgs (Uint64.of_int 2), + Hashtbl.find sent_msgs (Uint64.of_int 3) in + let%lwt _ = Lwt_io.printf "check_recvd_msgs: %d %d %d\n" + s1 s2 s3 in + assert_equal s1 3; + assert_equal s2 3; + assert_equal s3 4; + Lwt.return_unit + +let _ = Nocrypto_entropy_lwt.initialize () + +let () = + let view_len = 8 in + let xchg_len = 4 in + let period = 1.0 in + let fanout = 5 in + let seen_len = 10 in + + let (in_ch1, out_ch2) = Lwt_io.pipe () in + let (in_ch2, out_ch1) = Lwt_io.pipe () in + + let node1 = Node.init (u64 100L) in + let io1 = Io.init (Node.id node1) in_ch1 out_ch1 in + let view1 = + View.add (Node.init (u64 110L)) + (View.add (Node.init (u64 120L)) + (View.add (Node.init (u64 130L)) + (View.add (Node.init (u64 140L)) + (View.add (Node.init (u64 150L)) + (View.add (Node.init (u64 160L)) + (View.add (Node.init (u64 170L)) + View.empty)))))) in + let rc1 = Ringcast_lwt.init ~me:node1 ~view:view1 ~view_len ~xchg_len + ~period ~fanout ~seen_len ~io:io1 in + + let node2 = Node.init (u64 200L) in + let io2 = Io.init (Node.id node2) in_ch2 out_ch2 in + let view2 = + View.add (Node.init (u64 210L)) + (View.add (Node.init (u64 220L)) + (View.add (Node.init (u64 230L)) + (View.add (Node.init (u64 240L)) + (View.add (Node.init (u64 250L)) + (View.add (Node.init (u64 260L)) + (View.add (Node.init (u64 270L)) + View.empty)))))) in + let rc2 = Ringcast_lwt.init ~me:node2 ~view:view2 ~view_len ~xchg_len ~period ~fanout ~seen_len ~io:io2 in + + let timeout = Lwt_unix.sleep 5.5 in + Lwt_main.run @@ + Lwt.join [ + Lwt.choose [ Ringcast_lwt.run rc1; + Ringcast_lwt.run rc2; + read_chan in_ch1 rc1 node1 node2; + read_chan in_ch2 rc2 node2 node1; + Lwt.map (fun () -> Ringcast_lwt.shutdown rc1; + Ringcast_lwt.shutdown rc2) timeout ]; + forward 1.0 rc1 node1 (Uint64.of_int 1) + (Printf.sprintf "first message from %s" (Node.to_string node1)); + forward 1.5 rc1 node2 (Uint64.of_int 1) + (Printf.sprintf "first message #2 from %s" (Node.to_string node2)); + forward 2.0 rc1 node1 (Uint64.of_int 2) + (Printf.sprintf "second message from %s" (Node.to_string node1)); + forward 3.0 rc1 node2 (Uint64.of_int 3) + (Printf.sprintf "third message from %s" (Node.to_string node2)); + forward 4.0 rc1 node2 (Uint64.of_int 1) + (Printf.sprintf "first message #3 from %s" (Node.to_string node2)); + check_sent_msgs 5.3 + ] diff --git a/test/p2p-ringcast/dune b/test/p2p-ringcast/dune new file mode 100644 index 0000000..402a708 --- /dev/null +++ b/test/p2p-ringcast/dune @@ -0,0 +1,9 @@ +(test + (name test_ringcast) + (package p2p-ringcast) + (libraries + p2p-ringcast + oUnit + nocrypto.unix + ) +) diff --git a/test/p2p-ringcast/test_ringcast.ml b/test/p2p-ringcast/test_ringcast.ml new file mode 100644 index 0000000..e5bcf4a --- /dev/null +++ b/test/p2p-ringcast/test_ringcast.ml @@ -0,0 +1,96 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +open OUnit2 +open Printf +open Stdint + +module Node_id = P2p.Node_id +module Node = P2p.Node.Make (Node_id) +module View = P2p.View.Make (Node_id) (Node) +module Msg_id = P2p.Msg_id +module Ringcast = + P2p_ringcast.Make (Node_id) (Node) (View) (Msg_id) + +let u64 = Uint64.of_int64 +let pf = Fmt.pf +let out = Fmt.stdout + +let view_len = 8 +let xchg_len = 4 +let me = Node.init (u64 16L) + +let my_view = + View.add (Node.init (u64 7L)) + (View.add (Node.init (u64 11L)) + (View.add (Node.init (u64 13L)) + (View.add (Node.init (u64 17L)) + (View.add (Node.init (u64 19L)) + (View.add (Node.init (u64 23L)) + (View.add (Node.init (u64 41L)) + (View.add (Node.init (u64 49L)) + View.empty))))))) + +let my_view_str = + View.add (Node.init (u64 5L)) + (View.add (Node.init (u64 10L)) + (View.add (Node.init (u64 20L)) + (View.add (Node.init (u64 30L)) + (View.add (Node.init (u64 40L)) + (View.add (Node.init (u64 45L)) + (View.add (Node.init (u64 50L)) + (View.add (Node.init (u64 0L)) + View.empty))))))) + +let my_recvd = + View.add (Node.init (u64 5L)) + (View.add (Node.init (u64 10L)) + (View.add (Node.init (u64 20L)) + (View.add (Node.init (u64 30L)) + View.empty))) + +let test_gossip _ctx = + printf "\nRINGCAST GOSSIP\n"; + let view = my_view in + let xview = my_view_str in + let (dst, sent, view) = Ringcast.initiate ~me ~view ~xview ~xchg_len in + let recvd = my_recvd in + let dst = + match dst with + | Some dst -> dst + | None -> assert_failure "No gossip target" in + pf out "Gossip target: %a\n" Node.pp dst; + pf out "Gossip sent (%d):\n%a\n" (View.length sent) View.pp sent; + assert_equal (View.length sent) xchg_len; + pf out "Gossip received (%d):\n%a\n" (View.length recvd) View.pp recvd; + pf out "View before gossip (%d):\n%a\n" (View.length view) View.pp view; + let view = Ringcast.merge ~me ~view ~view_len ~sent ~recvd ~xchg_len in + pf out "View after gossip (%d):\n%a\n" (View.length view) View.pp view; + assert_equal (View.length view) view_len; + assert_equal (View.mem (Node.id me) view) false; + let resp = Ringcast.respond ~view ~xview ~recvd ~xchg_len ~src:me ~me in + pf out "Gossip response:\n%a\n" View.pp resp; + assert_equal (View.length resp) xchg_len + +let suite = + "suite">::: + [ + "gossip">:: test_gossip; + ] + +let () = + Nocrypto_entropy_unix.initialize (); + run_test_tt_main suite diff --git a/test/p2p-vicinity-lwt/dune b/test/p2p-vicinity-lwt/dune new file mode 100644 index 0000000..99f667f --- /dev/null +++ b/test/p2p-vicinity-lwt/dune @@ -0,0 +1,14 @@ +(tests + (names test_vicinity_lwt) + (package p2p-vicinity-lwt) + (libraries + p2p-vicinity + p2p-vicinity-lwt + lwt + oUnit + nocrypto.lwt + ) + (preprocess + (pps lwt_ppx) + ) +) diff --git a/test/p2p-vicinity-lwt/test_vicinity_lwt.ml b/test/p2p-vicinity-lwt/test_vicinity_lwt.ml new file mode 100644 index 0000000..f4e0529 --- /dev/null +++ b/test/p2p-vicinity-lwt/test_vicinity_lwt.ml @@ -0,0 +1,146 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +open Stdint + +let u64 = Uint64.of_int64 +let pf = Fmt.pf +let out = Fmt.stdout + +module Node_id = P2p.Node_id + +module Make_node (Node_id: P2p.S.NODE_ID) + : P2p_vicinity.S.NODE with type nid := Node_id.t = struct + + module Node = P2p.Node.Make (Node_id) + include Node + + (** 1 / (a - b) *) + let sim a b = + 1. /. Uint64.to_float + (Node_id.to_uint64 + (Node_id.distance (Node.id a) (Node.id b))) +end + +module Node = Make_node (Node_id) +module View = P2p.View.Make (Node_id) (Node) +module Vicinity = P2p_vicinity.Make (Node_id) (Node) (View) + +module Io = struct + + type t = { + node_id: Node_id.t; + in_chan : Lwt_io.input_channel; + out_chan : Lwt_io.output_channel; + } + + let init node_id in_chan out_chan = + { node_id; in_chan; out_chan } + + (** [initiate_gossip t node xchg] + sends [xchg] entries to node [dst] + and returns response *) + let initiate_gossip t dst xchg = + pf out "%a # INITIATE_GOSSIP to node %a\n" Node_id.pp t.node_id Node.pp dst; + pf out "xchg to send:\n%a\n" View.pp xchg; + flush stdout; + let%lwt _ = Lwt_io.write_value t.out_chan xchg in + Lwt_io.read_value t.in_chan + + (** [respond_gossip t node xchg] + sends [xchg] entries in response to node [dst] *) + let respond_gossip t dst xchg = + pf out "%a # RESPOND_GOSSIP to node %a\n" Node_id.pp t.node_id Node.pp dst; + pf out "xchg to send:\n%a\n" View.pp xchg; + flush stdout; + let%lwt _ = Lwt_io.write_value t.out_chan xchg in + Lwt.return_unit + + (** [gossip_recvd t node view recvd] + is called after entries are received during a gossip exchange; + allows rewriting [recvd] entries with the returned value. *) + let gossip_recvd _t _src recvd _view = + Lwt.return recvd + + (** [view_updated node view] + is called when [view] has been updated after a gossip exchange *) + let view_updated t node view = + pf out "%a # VIEW_UPDATED of node %a\n%a\n" Node_id.pp t.node_id Node.pp node View.pp view; + flush stdout; + Lwt.return_unit + + let get_xview _t = + View.empty +end + +module Vicinity_lwt = + P2p_vicinity_lwt.Make (Node_id) (Node) (View) (Vicinity) (Io) + +let rec read_chan ch vc node rnode = + let%lwt recvd = Lwt_io.read_value ch in + pf out "%a # READ_CHAN\n" Node_id.pp (Node.id node); + pf out "recvd:\n%a\n" View.pp recvd; + flush stdout; + let%lwt view = Vicinity_lwt.respond vc rnode recvd in + pf out "recvd:\n%a\n" View.pp recvd; + pf out "view:\n%a\n" View.pp view; + flush stdout; + read_chan ch vc node rnode + +let _ = Nocrypto_entropy_lwt.initialize () + +let () = + let view_len = 8 in + let xchg_len = 4 in + let period = 1.0 in + + let (in_ch1, out_ch2) = Lwt_io.pipe () in + let (in_ch2, out_ch1) = Lwt_io.pipe () in + + let node1 = Node.init (u64 100L) in + let io1 = Io.init (Node.id node1) in_ch1 out_ch1 in + let view1 = + View.add (Node.init (u64 110L)) + (View.add (Node.init (u64 120L)) + (View.add (Node.init (u64 130L)) + (View.add (Node.init (u64 140L)) + (View.add (Node.init (u64 150L)) + (View.add (Node.init (u64 160L)) + (View.add (Node.init (u64 170L)) + View.empty)))))) in + let vc1 = Vicinity_lwt.init ~me:node1 ~view:view1 ~view_len ~xchg_len ~period ~io:io1 in + + let node2 = Node.init (u64 200L) in + let io2 = Io.init (Node.id node2) in_ch2 out_ch2 in + let view2 = + View.add (Node.init (u64 210L)) + (View.add (Node.init (u64 220L)) + (View.add (Node.init (u64 230L)) + (View.add (Node.init (u64 240L)) + (View.add (Node.init (u64 250L)) + (View.add (Node.init (u64 260L)) + (View.add (Node.init (u64 270L)) + View.empty)))))) in + let vc2 = Vicinity_lwt.init ~me:node2 ~view:view2 ~view_len ~xchg_len ~period ~io:io2 in + + let timeout = Lwt_unix.sleep 5.5 in + Lwt_main.run @@ + Lwt.choose [ Vicinity_lwt.run vc1; + Vicinity_lwt.run vc2; + read_chan in_ch1 vc1 node1 node2; + read_chan in_ch2 vc2 node2 node1; + Lwt.map (fun () -> Vicinity_lwt.shutdown vc1; + Vicinity_lwt.shutdown vc2) timeout ] diff --git a/test/p2p-vicinity/dune b/test/p2p-vicinity/dune new file mode 100644 index 0000000..096e4b0 --- /dev/null +++ b/test/p2p-vicinity/dune @@ -0,0 +1,9 @@ +(test + (name test_vicinity) + (package p2p-vicinity) + (libraries + p2p-vicinity + oUnit + nocrypto.unix + ) +) diff --git a/test/p2p-vicinity/test_vicinity.ml b/test/p2p-vicinity/test_vicinity.ml new file mode 100644 index 0000000..c42b78a --- /dev/null +++ b/test/p2p-vicinity/test_vicinity.ml @@ -0,0 +1,107 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +open OUnit2 +open Printf +open Stdint + +module Node_id = P2p.Node_id + +module Make_node (Node_id: P2p.S.NODE_ID) + : P2p_vicinity.S.NODE with type nid := Node_id.t = struct + + module Node = P2p.Node.Make (Node_id) + include Node + + (** 1 / (a - b) *) + let sim a b = + 1. /. Uint64.to_float + (Node_id.to_uint64 + (Node_id.distance (Node.id a) (Node.id b))) +end + +module Node = Make_node (Node_id) +module View = P2p.View.Make (Node_id) (Node) +module Vicinity = P2p_vicinity.Make (Node_id) (Node) (View) + +let u64 = Uint64.of_int64 +let pf = Fmt.pf +let out = Fmt.stdout + +let view_len = 7 +let xchg_len = 5 +let me = Node.init (u64 23L) + +let my_view = + View.add (Node.init (u64 7L)) + (View.add (Node.init (u64 11L)) + (View.add (Node.init (u64 13L)) + (View.add (Node.init (u64 17L)) + (View.add (Node.init (u64 19L)) + (View.add (Node.init (u64 29L)) + (View.add (Node.init (u64 37L)) + View.empty)))))) + +let my_view_rnd = + View.add (Node.init (u64 10L)) + (View.add (Node.init (u64 20L)) + (View.add (Node.init (u64 30L)) + (View.add (Node.init (u64 40L)) + (View.add (Node.init (u64 50L)) + (View.add (Node.init (u64 60L)) + (View.add (Node.init (u64 70L)) + View.empty)))))) + +let my_recvd = + View.add (Node.init (u64 10L)) + (View.add (Node.init (u64 20L)) + (View.add (Node.init (u64 30L)) + (View.add (Node.init (u64 40L)) + (View.add (Node.init (u64 50L)) + View.empty)))) + +let test_gossip _ctx = + printf "\nVICINITY GOSSIP\n"; + let view = my_view in + let xview = my_view_rnd in + let (dst, sent, view) = Vicinity.initiate ~me ~view ~xview ~xchg_len in + let recvd = my_recvd in + let dst = + match dst with + | Some dst -> dst + | None -> assert_failure "No gossip target" in + pf out "Gossip target: %a\n" Node.pp dst; + pf out "Gossip sent (%d):\n%a\n" (View.length sent) View.pp sent; + assert_equal (View.length sent) xchg_len; + pf out "Gossip received (%d):\n%a\n" (View.length recvd) View.pp recvd; + pf out "View before gossip (%d):\n%a\n" (View.length view) View.pp view; + let view = Vicinity.merge ~me ~view ~view_len ~sent ~recvd ~xchg_len in + pf out "View after gossip (%d):\n%a\n" (View.length view) View.pp view; + assert_equal (View.length view) view_len; + assert_equal (View.mem (Node.id me) view) false; + let resp = Vicinity.respond ~view ~xview ~recvd ~xchg_len ~src:me ~me in + pf out "Gossip response:\n%a\n" View.pp resp; + assert_equal (View.length resp) xchg_len + +let suite = + "suite">::: + [ + "gossip">:: test_gossip; + ] + +let () = + Nocrypto_entropy_unix.initialize (); + run_test_tt_main suite diff --git a/test/p2p/dune b/test/p2p/dune new file mode 100644 index 0000000..d7274c3 --- /dev/null +++ b/test/p2p/dune @@ -0,0 +1,4 @@ +(test + (name test_view) + (package p2p) + (libraries oUnit p2p nocrypto.unix stdint)) diff --git a/test/p2p/test_gossip.ml b/test/p2p/test_gossip.ml new file mode 100644 index 0000000..fc5b23d --- /dev/null +++ b/test/p2p/test_gossip.ml @@ -0,0 +1,137 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +open Ringcast +open OUnit2 +open Printf + +let view_len = 8 +let xchg_len = 4 +let my_nid = "ME" +let my_data = 43 + +let print_view msg view = + printf "\n%s\n" msg; + View.iter (fun id n -> Printf.printf "%s: %d (%d)\n" id n.data n.age) view;; + +let print_xchg msg xchg = + Printf.printf "\n%s\n" msg; + View.iter (fun id n -> Printf.printf "%s: %d\n" id n.data) xchg;; + +let opt2str v = + match v with + | Some v -> v + | None -> "-" + +let opt2int v = + match v with + | Some v -> v + | None -> -1 + +let my_view = + add "a" 7 + (add "b" 11 + (add "c" 13 + (add "d" 17 + (add "e" 19 + (add "f" 23 + (add "g" 41 + (add "h" 49 + View.empty))))))) + +let my_recvd = + (add "W" 10 + (add "X" 20 + (add "Y" 30 + (add "Z" 40 + View.empty)))) + +let my_view_str = + add "A" 5 + (add "B" 10 + (add "C" 20 + (add "D" 30 + (add "E" 40 + (add "F" 45 + (add "G" 50 + (add "H" 0 + View.empty))))))) + +let distance _nid1 data1 _nid2 data2 = + let min_nid = 0 in + let max_nid = 50 in + let nid1 = data1 in + let nid2 = data2 in + let d = abs (nid2 - nid1) in + let d = if d <= (max_nid - min_nid) / 2 + then d + else max_nid + 1 - d in + let d = if (nid1 - nid2 = d) || (nid1 < nid2 && nid2 - nid1 != d) + then -1 * d + else d in + (* Printf.printf "distance %d %d = %d\n" nid1 nid2 d; *) + d + +let test_add _ctx = + let view = my_view in + print_view "add" view; + assert_equal (View.cardinal view) view_len + +let test_xchg _ctx = + let view = my_view in + let (nid, data, sent, _view) = + make_exchange view my_view_str xchg_len my_nid my_data distance in + printf "\nSEND TO %s (%d)\n" (opt2str nid) (opt2int data); + print_xchg "SEND:" sent; + print_newline (); + assert_equal (View.cardinal sent) xchg_len + +let test_recv _ctx = + let view = my_view in + let (nid, data, sent, view) = + make_exchange view my_view_str xchg_len my_nid my_data distance in + let recvd = my_recvd in + printf "\n\nSEND TO %s (%d)\n" (opt2str nid) (opt2int data); + print_view "VIEW BEFORE:" view; + print_xchg "SENT:" sent; + print_xchg "RECVD:" recvd; + assert_equal (View.cardinal view) (view_len - 1); + assert_equal (View.cardinal sent) xchg_len; + let view2 = merge_recvd view view_len recvd xchg_len my_nid my_data distance in + print_view "VIEW AFTER:" view2; + assert_equal (View.cardinal view2) view_len; + assert_equal (View.mem "ME" view2) false; + let (rnid, rdata) = ("x", 5) in + let resp = + make_response view2 my_view_str xchg_len rnid rdata recvd + my_nid my_data distance in + printf "\nRESPOND TO %s (%d)\n" rnid rdata; + print_xchg "RESP:" resp; + assert_equal (View.cardinal resp) xchg_len; + let (rnid, _rdata) = View.choose recvd in + assert_equal (View.mem rnid resp) false + +let suite = + "suite">::: + [ + "add">:: test_add; + "exchange">:: test_xchg; + "receive">:: test_recv; + ] + +let () = + Random.self_init (); + run_test_tt_main suite diff --git a/test/p2p/test_view.ml b/test/p2p/test_view.ml new file mode 100644 index 0000000..a3c92ab --- /dev/null +++ b/test/p2p/test_view.ml @@ -0,0 +1,82 @@ +(* + Copyright (C) 2019 TG x Thoth + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . +*) + +open OUnit2 +open Stdint + +let u64 = Uint64.of_int64 + +module Node_id = P2p.Node_id +module Node = P2p.Node.Make (Node_id) +module View = P2p.View.Make (Node_id) (Node) + +let my_view = + (View.add (Node.init (u64 7L)) + (View.add (Node.init (u64 11L) ~age:3 ~ver:2) + (View.add (Node.init (u64 13L)) + (View.add (Node.init (u64 17L)) + (View.add (Node.init (u64 23L)) + (View.add (Node.init (u64 19L)) + (View.add (Node.init (u64 49L)) + (View.add (Node.init (u64 47L)) + View.empty)))))))) + +let test_view _ctx = + let v = View.incr_age my_view in + assert_equal (View.length v) 8; + let v = View.remove (Uint64.of_int64 17L) v in + assert_equal (View.length v) 7; + let n = + match View.find (u64 11L) v with + | Some n -> n + | None -> assert_failure "11 not found" in + assert_equal (Node.id n) (u64 11L); + let n = Node.incr_age n in + assert_equal (Node.age n) 5; + assert_equal (Node.ver n) 2; + let n = Node.zero_age n in + assert_equal (Node.age n) 0; + let n2 = + match View.find (u64 13L) v with + | Some n -> n + | None -> assert_failure "13 not found" in + assert_equal (Node.age n2) 1; + assert_equal (Node.ver n2) 0; + assert_equal (Node.compare n n2) (-1); + assert_equal (Node.compare n n) 0; + assert_equal (Node.compare n2 n) 1; + let l = View.to_list v in + assert_equal l [ + Node.init (u64 7L) ~age:1; + Node.init (u64 11L) ~age:4 ~ver:2; + Node.init (u64 13L) ~age:1; + Node.init (u64 19L) ~age:1; + Node.init (u64 23L) ~age:1; + Node.init (u64 47L) ~age:1; + Node.init (u64 49L) ~age:1; + ]; + let v2 = View.of_list ((Node.init (u64 11L)) :: l) in + assert_equal (View.to_list v2) l + +let suite = + "suite">::: + [ + "view">:: test_view; + ] + +let () = + Nocrypto_entropy_unix.initialize (); + run_test_tt_main suite