diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,26 @@ +# 0.3.1 + +- Released to hackage.org +- SMP agent protocol changes: + - move SMP server from agent commands NEW/JOIN to agent config + - send CON to user only when the 1st party responds HELLO +- Fix REPLY vulnerability +- Fix transaction busy error + +# 0.3.0 + +- SMP encrypted transport over TCP +- Standard X509/PKCS8 encoding for RSA keys +- Sign and verify agent messages +- Verify message integrity based on previous message hash and ID +- Prevent timing attack allowing to determine if queue exists +- Only allow correct RSA keys and signature sizes + +# 0.2.0 + +- SMP client library +- SMP agent with E2E encryption + +# 0.1.0 + +- SMP protocol server implementation without encryption diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,661 @@ + 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,69 @@ +# SimpleXMQ + +[![GitHub build](https://github.com/simplex-chat/simplexmq/workflows/build/badge.svg)](https://github.com/simplex-chat/simplexmq/actions?query=workflow%3Abuild) +[![GitHub release](https://img.shields.io/github/v/release/simplex-chat/simplexmq)](https://github.com/simplex-chat/simplexmq/releases) + +## Message broker for unidirectional (simplex) queues + +SimpleXMQ is a message broker for managing message queues and sending messages over public network. It consists of SMP server, SMP client library and SMP agent that implement [SMP protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md) for client-server communication and [SMP agent protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md) to manage duplex connections via simplex queues on multiple SMP servers. + +SMP protocol is inspired by [Redis serialization protocol](https://redis.io/topics/protocol), but it is much simpler - it currently has only 8 client commands and 6 server responses. + +SimpleXMQ is implemented in Haskell - it benefits from robust software transactional memory (STM) and concurrency primitives that Haskell provides. + +## SimpleXMQ roadmap + +- Streams - high performance message queues. See [Streams RFC](https://github.com/simplex-chat/simplexmq/blob/master/rfcs/2021-02-28-streams.md) for details. +- "Small" connection groups, when each message will be sent by the SMP agent to multiple connections with a single client command. See [Groups RFC](https://github.com/simplex-chat/simplexmq/blob/master/rfcs/2021-03-18-groups.md) for details. +- SMP agents cluster to share connections and message management by multiple agents (for example, it would enable multi-device use for [simplex-chat](https://github.com/simplex-chat/simplex-chat)). +- SMP queue redundancy and rotation in SMP agent duplex connections. +- "Large" groups design and implementation. + +## Components + +### SMP server + +[SMP server](https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-server/Main.hs) can be run on any Linux distribution without any dependencies. It uses in-memory persistence with an optional append-only log of created queues that allows to re-start the server without losing the connections. This log is compacted on every server restart, permanently removing suspended and removed queues. + +To enable the queue logging, uncomment `enable: on` option in `smp-server.ini` configuration file that is created the first time the server is started. + +On the first start the server generates an RSA key pair for encrypted transport handshake and outputs hash of the public key every time it runs - this hash should be used as part of the server address: `:5223#`. + +SMP server implements [SMP protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md). + +### SMP client library + +[SMP client](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Client.hs) is a Haskell library to connect to SMP servers that allows to: +- execute commands with a functional API. +- receive messages and other notifications via STM queue. +- automatically send keep-alive commands. + +### SMP agent + +[SMP agent library](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Agent.hs) can be used to run SMP agent as part of another application and to communicate with the agent via STM queues, without serializing and parsing commands and responses. + +Haskell type [ACommand](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Agent/Protocol.hs) represents SMP agent protocol to communicate via STM queues. + +See [simplex-chat](https://github.com/simplex-chat/simplex-chat) terminal UI for the example of integrating SMP agent into another application. + +[SMP agent executable](https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-agent/Main.hs) can be used to run a standalone SMP agent process that implements plaintext [SMP agent protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md) via TCP port 5224, so it can be used via telnet. It can be deployed in private networks to share access to the connections between multiple applications and services. + +## Using SMP server and SMP agent + +You can either run SMP server locally or try local SMP agent with the deployed demo server: + +`smp1.simplex.im:5223#pLdiGvm0jD1CMblnov6Edd/391OrYsShw+RgdfR0ChA=` + +It's the easiest to try SMP agent via a prototype [simplex-chat](https://github.com/simplex-chat/simplex-chat) terminal UI. + +## SMP server design + +![SMP server design](https://raw.githubusercontent.com/simplex-chat/simplexmq/master/design/server.svg) + +## SMP agent design + +![SMP agent design](https://raw.githubusercontent.com/simplex-chat/simplexmq/master/design/agent2.svg) + +## License + +[AGPL v3](https://github.com/simplex-chat/simplexmq/blob/master/LICENSE) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/apps/smp-agent/Main.hs b/apps/smp-agent/Main.hs new file mode 100644 --- /dev/null +++ b/apps/smp-agent/Main.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Logger.Simple +import qualified Data.List.NonEmpty as L +import Simplex.Messaging.Agent (runSMPAgent) +import Simplex.Messaging.Agent.Env.SQLite +import Simplex.Messaging.Client (smpDefaultConfig) + +cfg :: AgentConfig +cfg = + AgentConfig + { tcpPort = "5224", + smpServers = L.fromList ["localhost:5223#KXNE1m2E1m0lm92WGKet9CL6+lO742Vy5G6nsrkvgs8="], + rsaKeySize = 2048 `div` 8, + connIdBytes = 12, + tbqSize = 16, + dbFile = "smp-agent.db", + smpCfg = smpDefaultConfig + } + +logCfg :: LogConfig +logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} + +main :: IO () +main = do + putStrLn $ "SMP agent listening on port " ++ tcpPort (cfg :: AgentConfig) + setLogLevel LogInfo -- LogError + withGlobalLogging logCfg $ runSMPAgent cfg diff --git a/apps/smp-server/Main.hs b/apps/smp-server/Main.hs new file mode 100644 --- /dev/null +++ b/apps/smp-server/Main.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Monad (unless, when) +import qualified Crypto.Store.PKCS8 as S +import Data.ByteString.Base64 (encode) +import qualified Data.ByteString.Char8 as B +import Data.Char (toLower) +import Data.Functor (($>)) +import Data.Ini (lookupValue, readIniFile) +import qualified Data.Text as T +import Data.X509 (PrivKey (PrivKeyRSA)) +import Options.Applicative +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Server (runSMPServer) +import Simplex.Messaging.Server.Env.STM +import Simplex.Messaging.Server.StoreLog (StoreLog, openReadStoreLog) +import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.Exit (exitFailure) +import System.FilePath (combine) +import System.IO (IOMode (..), hFlush, stdout) + +cfg :: ServerConfig +cfg = + ServerConfig + { tcpPort = "5223", + tbqSize = 16, + queueIdBytes = 12, + msgIdBytes = 6, + storeLog = Nothing, + -- key is loaded from the file server_key in /etc/opt/simplex directory + serverPrivateKey = undefined + } + +newKeySize :: Int +newKeySize = 2048 `div` 8 + +cfgDir :: FilePath +cfgDir = "/etc/opt/simplex" + +logDir :: FilePath +logDir = "/var/opt/simplex" + +defaultStoreLogFile :: FilePath +defaultStoreLogFile = combine logDir "smp-server-store.log" + +main :: IO () +main = do + opts <- getServerOpts + putStrLn "SMP Server (-h for help)" + ini <- readCreateIni opts + storeLog <- openStoreLog ini + pk <- readCreateKey + B.putStrLn $ "transport key hash: " <> serverKeyHash pk + putStrLn $ "listening on port " <> tcpPort cfg + runSMPServer cfg {serverPrivateKey = pk, storeLog} + +data IniOpts = IniOpts + { enableStoreLog :: Bool, + storeLogFile :: FilePath + } + +readCreateIni :: ServerOpts -> IO IniOpts +readCreateIni ServerOpts {configFile} = do + createDirectoryIfMissing True cfgDir + doesFileExist configFile >>= (`unless` createIni) + readIni + where + readIni :: IO IniOpts + readIni = do + ini <- either exitError pure =<< readIniFile configFile + let enableStoreLog = (== Right "on") $ lookupValue "STORE_LOG" "enable" ini + storeLogFile = either (const defaultStoreLogFile) T.unpack $ lookupValue "STORE_LOG" "file" ini + pure IniOpts {enableStoreLog, storeLogFile} + exitError e = do + putStrLn $ "error reading config file " <> configFile <> ": " <> e + exitFailure + createIni :: IO () + createIni = do + confirm $ "Save default ini file to " <> configFile + writeFile + configFile + "[STORE_LOG]\n\ + \# The server uses STM memory to store SMP queues and messages,\n\ + \# that will be lost on restart (e.g., as with redis).\n\ + \# This option enables saving SMP queues to append only log,\n\ + \# and restoring them when the server is started.\n\ + \# Log is compacted on start (deleted queues are removed).\n\ + \# The messages in the queues are not logged.\n\ + \\n\ + \# enable: on\n\ + \# file: /var/opt/simplex/smp-server-store.log\n" + +readCreateKey :: IO C.FullPrivateKey +readCreateKey = do + createDirectoryIfMissing True cfgDir + let path = combine cfgDir "server_key" + hasKey <- doesFileExist path + (if hasKey then readKey else createKey) path + where + createKey :: FilePath -> IO C.FullPrivateKey + createKey path = do + confirm "Generate new server key pair" + (_, pk) <- C.generateKeyPair newKeySize + S.writeKeyFile S.TraditionalFormat path [PrivKeyRSA $ C.rsaPrivateKey pk] + pure pk + readKey :: FilePath -> IO C.FullPrivateKey + readKey path = do + S.readKeyFile path >>= \case + [S.Unprotected (PrivKeyRSA pk)] -> pure $ C.FullPrivateKey pk + [_] -> errorExit "not RSA key" + [] -> errorExit "invalid key file format" + _ -> errorExit "more than one key" + where + errorExit :: String -> IO b + errorExit e = putStrLn (e <> ": " <> path) >> exitFailure + +confirm :: String -> IO () +confirm msg = do + putStr $ msg <> " (y/N): " + hFlush stdout + ok <- getLine + when (map toLower ok /= "y") exitFailure + +serverKeyHash :: C.FullPrivateKey -> B.ByteString +serverKeyHash = encode . C.unKeyHash . C.publicKeyHash . C.publicKey + +openStoreLog :: IniOpts -> IO (Maybe (StoreLog 'ReadMode)) +openStoreLog IniOpts {enableStoreLog, storeLogFile = f} + | enableStoreLog = do + createDirectoryIfMissing True logDir + putStrLn ("store log: " <> f) + Just <$> openReadStoreLog f + | otherwise = putStrLn "store log disabled" $> Nothing + +newtype ServerOpts = ServerOpts + { configFile :: FilePath + } + +serverOpts :: Parser ServerOpts +serverOpts = + ServerOpts + <$> strOption + ( long "config" + <> short 'c' + <> metavar "INI_FILE" + <> help ("config file (" <> defaultIniFile <> ")") + <> value defaultIniFile + ) + where + defaultIniFile = combine cfgDir "smp-server.ini" + +getServerOpts :: IO ServerOpts +getServerOpts = execParser opts + where + opts = + info + (serverOpts <**> helper) + ( fullDesc + <> header "Simplex Messaging Protocol (SMP) Server" + <> progDesc "Start server with INI_FILE (created on first run)" + ) diff --git a/simplexmq.cabal b/simplexmq.cabal new file mode 100644 --- /dev/null +++ b/simplexmq.cabal @@ -0,0 +1,227 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 386cce2d4e066eae195c77973524bda82fab223da4b8f504e9932f05b562594f + +name: simplexmq +version: 0.3.1 +synopsis: SimpleXMQ message broker +description: This package includes <./docs/Simplex-Messaging-Server.html server>, + <./docs/Simplex-Messaging-Client.html client> and + <./docs/Simplex-Messaging-Agent.html agent> for SMP protocols: + . + * + * + . + See built with SimpleXMQ broker. +category: Chat, Network, Web, System, Cryptography +homepage: https://github.com/simplex-chat/simplexmq#readme +author: simplex.chat +maintainer: chat@simplex.chat +copyright: 2020 simplex.chat +license: AGPL-3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +library + exposed-modules: + Simplex.Messaging.Agent + Simplex.Messaging.Agent.Client + Simplex.Messaging.Agent.Env.SQLite + Simplex.Messaging.Agent.Protocol + Simplex.Messaging.Agent.Store + Simplex.Messaging.Agent.Store.SQLite + Simplex.Messaging.Agent.Store.SQLite.Schema + Simplex.Messaging.Client + Simplex.Messaging.Crypto + Simplex.Messaging.Parsers + Simplex.Messaging.Protocol + Simplex.Messaging.Server + Simplex.Messaging.Server.Env.STM + Simplex.Messaging.Server.MsgStore + Simplex.Messaging.Server.MsgStore.STM + Simplex.Messaging.Server.QueueStore + Simplex.Messaging.Server.QueueStore.STM + Simplex.Messaging.Server.StoreLog + Simplex.Messaging.Transport + Simplex.Messaging.Util + other-modules: + Paths_simplexmq + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns + build-depends: + QuickCheck ==2.13.* + , ansi-terminal ==0.10.* + , asn1-encoding ==0.9.* + , asn1-types ==0.3.* + , async ==2.2.* + , attoparsec ==0.13.* + , base >=4.7 && <5 + , base64-bytestring >=1.0 && <1.3 + , bytestring ==0.10.* + , containers ==0.6.* + , cryptonite ==0.26.* + , directory ==1.3.* + , filepath ==1.4.* + , generic-random ==1.3.* + , iso8601-time ==0.1.* + , memory ==0.15.* + , mtl ==2.2.* + , network ==3.1.* + , network-transport ==0.5.* + , random ==1.1.* + , simple-logger ==0.1.* + , sqlite-simple ==0.4.* + , stm ==2.5.* + , template-haskell ==2.15.* + , text ==1.2.* + , time ==1.9.* + , transformers ==0.5.* + , unliftio ==0.2.* + , unliftio-core ==0.1.* + , x509 ==1.7.* + default-language: Haskell2010 + +executable smp-agent + main-is: Main.hs + other-modules: + Paths_simplexmq + hs-source-dirs: + apps/smp-agent + ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded + build-depends: + QuickCheck ==2.13.* + , ansi-terminal ==0.10.* + , asn1-encoding ==0.9.* + , asn1-types ==0.3.* + , async ==2.2.* + , attoparsec ==0.13.* + , base >=4.7 && <5 + , base64-bytestring >=1.0 && <1.3 + , bytestring ==0.10.* + , containers ==0.6.* + , cryptonite ==0.26.* + , directory ==1.3.* + , filepath ==1.4.* + , generic-random ==1.3.* + , iso8601-time ==0.1.* + , memory ==0.15.* + , mtl ==2.2.* + , network ==3.1.* + , network-transport ==0.5.* + , random ==1.1.* + , simple-logger ==0.1.* + , simplexmq + , sqlite-simple ==0.4.* + , stm ==2.5.* + , template-haskell ==2.15.* + , text ==1.2.* + , time ==1.9.* + , transformers ==0.5.* + , unliftio ==0.2.* + , unliftio-core ==0.1.* + , x509 ==1.7.* + default-language: Haskell2010 + +executable smp-server + main-is: Main.hs + other-modules: + Paths_simplexmq + hs-source-dirs: + apps/smp-server + ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded + build-depends: + QuickCheck ==2.13.* + , ansi-terminal ==0.10.* + , asn1-encoding ==0.9.* + , asn1-types ==0.3.* + , async ==2.2.* + , attoparsec ==0.13.* + , base >=4.7 && <5 + , base64-bytestring >=1.0 && <1.3 + , bytestring ==0.10.* + , containers ==0.6.* + , cryptonite ==0.26.* + , cryptostore ==0.2.* + , directory ==1.3.* + , filepath ==1.4.* + , generic-random ==1.3.* + , ini ==0.4.* + , iso8601-time ==0.1.* + , memory ==0.15.* + , mtl ==2.2.* + , network ==3.1.* + , network-transport ==0.5.* + , optparse-applicative ==0.15.* + , random ==1.1.* + , simple-logger ==0.1.* + , simplexmq + , sqlite-simple ==0.4.* + , stm ==2.5.* + , template-haskell ==2.15.* + , text ==1.2.* + , time ==1.9.* + , transformers ==0.5.* + , unliftio ==0.2.* + , unliftio-core ==0.1.* + , x509 ==1.7.* + default-language: Haskell2010 + +test-suite smp-server-test + type: exitcode-stdio-1.0 + main-is: Test.hs + other-modules: + AgentTests + AgentTests.SQLiteTests + ProtocolErrorTests + ServerTests + SMPAgentClient + SMPClient + Paths_simplexmq + hs-source-dirs: + tests + ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns + build-depends: + HUnit ==1.6.* + , QuickCheck ==2.13.* + , ansi-terminal ==0.10.* + , asn1-encoding ==0.9.* + , asn1-types ==0.3.* + , async ==2.2.* + , attoparsec ==0.13.* + , base >=4.7 && <5 + , base64-bytestring >=1.0 && <1.3 + , bytestring ==0.10.* + , containers ==0.6.* + , cryptonite ==0.26.* + , directory ==1.3.* + , filepath ==1.4.* + , generic-random ==1.3.* + , hspec ==2.7.* + , hspec-core ==2.7.* + , iso8601-time ==0.1.* + , memory ==0.15.* + , mtl ==2.2.* + , network ==3.1.* + , network-transport ==0.5.* + , random ==1.1.* + , simple-logger ==0.1.* + , simplexmq + , sqlite-simple ==0.4.* + , stm ==2.5.* + , template-haskell ==2.15.* + , text ==1.2.* + , time ==1.9.* + , timeit ==2.0.* + , transformers ==0.5.* + , unliftio ==0.2.* + , unliftio-core ==0.1.* + , x509 ==1.7.* + default-language: Haskell2010 diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs new file mode 100644 --- /dev/null +++ b/src/Simplex/Messaging/Agent.hs @@ -0,0 +1,417 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Simplex.Messaging.Agent +-- Copyright : (c) simplex.chat +-- License : AGPL-3 +-- +-- Maintainer : chat@simplex.chat +-- Stability : experimental +-- Portability : non-portable +-- +-- This module defines SMP protocol agent with SQLite persistence. +-- +-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md +module Simplex.Messaging.Agent + ( runSMPAgent, + runSMPAgentBlocking, + getSMPAgentClient, + runSMPAgentClient, + ) +where + +import Control.Concurrent.STM (stateTVar) +import Control.Logger.Simple (logInfo, showText) +import Control.Monad.Except +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.Reader +import Crypto.Random (MonadRandom) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as L +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) +import Data.Time.Clock +import Database.SQLite.Simple (SQLError) +import Simplex.Messaging.Agent.Client +import Simplex.Messaging.Agent.Env.SQLite +import Simplex.Messaging.Agent.Protocol +import Simplex.Messaging.Agent.Store +import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore, connectSQLiteStore) +import Simplex.Messaging.Client (SMPServerTransmission) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Protocol (CorrId (..), MsgBody, SenderPublicKey) +import qualified Simplex.Messaging.Protocol as SMP +import Simplex.Messaging.Transport (putLn, runTCPServer) +import Simplex.Messaging.Util (bshow) +import System.IO (Handle) +import System.Random (randomR) +import UnliftIO.Async (race_) +import qualified UnliftIO.Exception as E +import UnliftIO.STM + +-- | Runs an SMP agent as a TCP service using passed configuration. +-- +-- See a full agent executable here: https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-agent/Main.hs +runSMPAgent :: (MonadRandom m, MonadUnliftIO m) => AgentConfig -> m () +runSMPAgent cfg = newEmptyTMVarIO >>= (`runSMPAgentBlocking` cfg) + +-- | Runs an SMP agent as a TCP service using passed configuration with signalling. +-- +-- This function uses passed TMVar to signal when the server is ready to accept TCP requests (True) +-- and when it is disconnected from the TCP socket once the server thread is killed (False). +runSMPAgentBlocking :: (MonadRandom m, MonadUnliftIO m) => TMVar Bool -> AgentConfig -> m () +runSMPAgentBlocking started cfg@AgentConfig {tcpPort} = runReaderT smpAgent =<< newSMPAgentEnv cfg + where + smpAgent :: (MonadUnliftIO m', MonadReader Env m') => m' () + smpAgent = runTCPServer started tcpPort $ \h -> do + liftIO $ putLn h "Welcome to SMP v0.3.1 agent" + c <- getSMPAgentClient + logConnection c True + race_ (connectClient h c) (runSMPAgentClient c) + `E.finally` (closeSMPServerClients c >> logConnection c False) + +-- | Creates an SMP agent instance that receives commands and sends responses via 'TBQueue's. +getSMPAgentClient :: (MonadUnliftIO m, MonadReader Env m) => m AgentClient +getSMPAgentClient = do + n <- asks clientCounter + cfg <- asks config + atomically $ newAgentClient n cfg + +connectClient :: MonadUnliftIO m => Handle -> AgentClient -> m () +connectClient h c = race_ (send h c) (receive h c) + +logConnection :: MonadUnliftIO m => AgentClient -> Bool -> m () +logConnection c connected = + let event = if connected then "connected to" else "disconnected from" + in logInfo $ T.unwords ["client", showText (clientId c), event, "Agent"] + +-- | Runs an SMP agent instance that receives commands and sends responses via 'TBQueue's. +runSMPAgentClient :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m () +runSMPAgentClient c = do + db <- asks $ dbFile . config + s1 <- connectSQLiteStore db + s2 <- connectSQLiteStore db + race_ (subscriber c s1) (client c s2) + +receive :: forall m. MonadUnliftIO m => Handle -> AgentClient -> m () +receive h c@AgentClient {rcvQ, sndQ} = forever $ do + (corrId, cAlias, cmdOrErr) <- tGet SClient h + case cmdOrErr of + Right cmd -> write rcvQ (corrId, cAlias, cmd) + Left e -> write sndQ (corrId, cAlias, ERR e) + where + write :: TBQueue (ATransmission p) -> ATransmission p -> m () + write q t = do + logClient c "-->" t + atomically $ writeTBQueue q t + +send :: MonadUnliftIO m => Handle -> AgentClient -> m () +send h c@AgentClient {sndQ} = forever $ do + t <- atomically $ readTBQueue sndQ + tPut h t + logClient c "<--" t + +logClient :: MonadUnliftIO m => AgentClient -> ByteString -> ATransmission a -> m () +logClient AgentClient {clientId} dir (CorrId corrId, cAlias, cmd) = do + logInfo . decodeUtf8 $ B.unwords [bshow clientId, dir, "A :", corrId, cAlias, B.takeWhile (/= ' ') $ serializeCommand cmd] + +client :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> SQLiteStore -> m () +client c@AgentClient {rcvQ, sndQ} st = forever $ do + t@(corrId, cAlias, _) <- atomically $ readTBQueue rcvQ + runExceptT (processCommand c st t) >>= \case + Left e -> atomically $ writeTBQueue sndQ (corrId, cAlias, ERR e) + Right _ -> return () + +withStore :: + AgentMonad m => + (forall m'. (MonadUnliftIO m', MonadError StoreError m') => m' a) -> + m a +withStore action = do + runExceptT (action `E.catch` handleInternal) >>= \case + Right c -> return c + Left e -> throwError $ storeError e + where + handleInternal :: (MonadError StoreError m') => SQLError -> m' a + handleInternal e = throwError . SEInternal $ bshow e + storeError :: StoreError -> AgentErrorType + storeError = \case + SEConnNotFound -> CONN UNKNOWN + SEConnDuplicate -> CONN DUPLICATE + e -> INTERNAL $ show e + +processCommand :: forall m. AgentMonad m => AgentClient -> SQLiteStore -> ATransmission 'Client -> m () +processCommand c@AgentClient {sndQ} st (corrId, connAlias, cmd) = + case cmd of + NEW -> createNewConnection + JOIN smpQueueInfo replyMode -> joinConnection smpQueueInfo replyMode + SUB -> subscribeConnection connAlias + SUBALL -> subscribeAll + SEND msgBody -> sendMessage msgBody + OFF -> suspendConnection + DEL -> deleteConnection + where + createNewConnection :: m () + createNewConnection = do + -- TODO create connection alias if not passed + -- make connAlias Maybe? + srv <- getSMPServer + (rq, qInfo) <- newReceiveQueue c srv connAlias + withStore $ createRcvConn st rq + respond $ INV qInfo + + getSMPServer :: m SMPServer + getSMPServer = + asks (smpServers . config) >>= \case + srv :| [] -> pure srv + servers -> do + gen <- asks randomServer + i <- atomically . stateTVar gen $ randomR (0, L.length servers - 1) + pure $ servers L.!! i + + joinConnection :: SMPQueueInfo -> ReplyMode -> m () + joinConnection qInfo (ReplyMode replyMode) = do + -- TODO create connection alias if not passed + -- make connAlias Maybe? + (sq, senderKey, verifyKey) <- newSendQueue qInfo connAlias + withStore $ createSndConn st sq + connectToSendQueue c st sq senderKey verifyKey + when (replyMode == On) $ createReplyQueue sq + -- TODO this response is disabled to avoid two responses in terminal client (OK + CON), + -- respond OK + + subscribeConnection :: ConnAlias -> m () + subscribeConnection cAlias = + withStore (getConn st cAlias) >>= \case + SomeConn _ (DuplexConnection _ rq _) -> subscribe rq + SomeConn _ (RcvConnection _ rq) -> subscribe rq + _ -> throwError $ CONN SIMPLEX + where + subscribe rq = subscribeQueue c rq cAlias >> respond' cAlias OK + + -- TODO remove - hack for subscribing to all; respond' and parameterization of subscribeConnection are byproduct + subscribeAll :: m () + subscribeAll = withStore (getAllConnAliases st) >>= mapM_ subscribeConnection + + sendMessage :: MsgBody -> m () + sendMessage msgBody = + withStore (getConn st connAlias) >>= \case + SomeConn _ (DuplexConnection _ _ sq) -> sendMsg sq + SomeConn _ (SndConnection _ sq) -> sendMsg sq + _ -> throwError $ CONN SIMPLEX + where + sendMsg sq = do + internalTs <- liftIO getCurrentTime + (internalId, internalSndId, previousMsgHash) <- withStore $ updateSndIds st sq + let msgStr = + serializeSMPMessage + SMPMessage + { senderMsgId = unSndId internalSndId, + senderTimestamp = internalTs, + previousMsgHash, + agentMessage = A_MSG msgBody + } + msgHash = C.sha256Hash msgStr + withStore $ + createSndMsg st sq $ + SndMsgData {internalId, internalSndId, internalTs, msgBody, internalHash = msgHash} + sendAgentMessage c sq msgStr + respond $ SENT (unId internalId) + + suspendConnection :: m () + suspendConnection = + withStore (getConn st connAlias) >>= \case + SomeConn _ (DuplexConnection _ rq _) -> suspend rq + SomeConn _ (RcvConnection _ rq) -> suspend rq + _ -> throwError $ CONN SIMPLEX + where + suspend rq = suspendQueue c rq >> respond OK + + deleteConnection :: m () + deleteConnection = + withStore (getConn st connAlias) >>= \case + SomeConn _ (DuplexConnection _ rq _) -> delete rq + SomeConn _ (RcvConnection _ rq) -> delete rq + _ -> delConn + where + delConn = withStore (deleteConn st connAlias) >> respond OK + delete rq = do + deleteQueue c rq + removeSubscription c connAlias + delConn + + createReplyQueue :: SndQueue -> m () + createReplyQueue sq = do + srv <- getSMPServer + (rq, qInfo) <- newReceiveQueue c srv connAlias + withStore $ upgradeSndConnToDuplex st connAlias rq + senderTimestamp <- liftIO getCurrentTime + sendAgentMessage c sq . serializeSMPMessage $ + SMPMessage + { senderMsgId = 0, + senderTimestamp, + previousMsgHash = "", + agentMessage = REPLY qInfo + } + + respond :: ACommand 'Agent -> m () + respond = respond' connAlias + + respond' :: ConnAlias -> ACommand 'Agent -> m () + respond' cAlias resp = atomically $ writeTBQueue sndQ (corrId, cAlias, resp) + +subscriber :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> SQLiteStore -> m () +subscriber c@AgentClient {msgQ} st = forever $ do + -- TODO this will only process messages and notifications + t <- atomically $ readTBQueue msgQ + runExceptT (processSMPTransmission c st t) >>= \case + Left e -> liftIO $ print e + Right _ -> return () + +processSMPTransmission :: forall m. AgentMonad m => AgentClient -> SQLiteStore -> SMPServerTransmission -> m () +processSMPTransmission c@AgentClient {sndQ} st (srv, rId, cmd) = do + withStore (getRcvConn st srv rId) >>= \case + SomeConn SCDuplex (DuplexConnection _ rq _) -> processSMP SCDuplex rq + SomeConn SCRcv (RcvConnection _ rq) -> processSMP SCRcv rq + _ -> atomically $ writeTBQueue sndQ ("", "", ERR $ CONN SIMPLEX) + where + processSMP :: SConnType c -> RcvQueue -> m () + processSMP cType rq@RcvQueue {connAlias, status} = + case cmd of + SMP.MSG srvMsgId srvTs msgBody -> do + -- TODO deduplicate with previously received + msg <- decryptAndVerify rq msgBody + let msgHash = C.sha256Hash msg + agentMsg <- liftEither $ parseSMPMessage msg + case agentMsg of + SMPConfirmation senderKey -> smpConfirmation senderKey + SMPMessage {agentMessage, senderMsgId, senderTimestamp, previousMsgHash} -> + case agentMessage of + HELLO verifyKey _ -> helloMsg verifyKey msgBody + REPLY qInfo -> replyMsg qInfo + A_MSG body -> agentClientMsg previousMsgHash (senderMsgId, senderTimestamp) (srvMsgId, srvTs) body msgHash + sendAck c rq + return () + SMP.END -> do + removeSubscription c connAlias + logServer "<--" c srv rId "END" + notify END + _ -> do + logServer "<--" c srv rId $ "unexpected: " <> bshow cmd + notify . ERR $ BROKER UNEXPECTED + where + notify :: ACommand 'Agent -> m () + notify msg = atomically $ writeTBQueue sndQ ("", connAlias, msg) + + prohibited :: m () + prohibited = notify . ERR $ AGENT A_PROHIBITED + + smpConfirmation :: SenderPublicKey -> m () + smpConfirmation senderKey = do + logServer "<--" c srv rId "MSG " + case status of + New -> do + -- TODO currently it automatically allows whoever sends the confirmation + -- Commands CONF and LET are not supported in v0.2 + withStore $ setRcvQueueStatus st rq Confirmed + -- TODO update sender key in the store? + secureQueue c rq senderKey + withStore $ setRcvQueueStatus st rq Secured + _ -> prohibited + + helloMsg :: SenderPublicKey -> ByteString -> m () + helloMsg verifyKey msgBody = do + logServer "<--" c srv rId "MSG " + case status of + Active -> prohibited + _ -> do + void $ verifyMessage (Just verifyKey) msgBody + withStore $ setRcvQueueActive st rq verifyKey + case cType of + SCDuplex -> notify CON + _ -> pure () + + replyMsg :: SMPQueueInfo -> m () + replyMsg qInfo = do + logServer "<--" c srv rId "MSG " + case cType of + SCRcv -> do + (sq, senderKey, verifyKey) <- newSendQueue qInfo connAlias + withStore $ upgradeRcvConnToDuplex st connAlias sq + connectToSendQueue c st sq senderKey verifyKey + notify CON + _ -> prohibited + + agentClientMsg :: PrevRcvMsgHash -> (ExternalSndId, ExternalSndTs) -> (BrokerId, BrokerTs) -> MsgBody -> MsgHash -> m () + agentClientMsg receivedPrevMsgHash senderMeta brokerMeta msgBody msgHash = do + logServer "<--" c srv rId "MSG " + case status of + Active -> do + internalTs <- liftIO getCurrentTime + (internalId, internalRcvId, prevExtSndId, prevRcvMsgHash) <- withStore $ updateRcvIds st rq + let msgIntegrity = checkMsgIntegrity prevExtSndId (fst senderMeta) prevRcvMsgHash receivedPrevMsgHash + withStore $ + createRcvMsg st rq $ + RcvMsgData + { internalId, + internalRcvId, + internalTs, + senderMeta, + brokerMeta, + msgBody, + internalHash = msgHash, + externalPrevSndHash = receivedPrevMsgHash, + msgIntegrity + } + notify + MSG + { recipientMeta = (unId internalId, internalTs), + senderMeta, + brokerMeta, + msgBody, + msgIntegrity + } + _ -> prohibited + + checkMsgIntegrity :: PrevExternalSndId -> ExternalSndId -> PrevRcvMsgHash -> ByteString -> MsgIntegrity + checkMsgIntegrity prevExtSndId extSndId internalPrevMsgHash receivedPrevMsgHash + | extSndId == prevExtSndId + 1 && internalPrevMsgHash == receivedPrevMsgHash = MsgOk + | extSndId < prevExtSndId = MsgError $ MsgBadId extSndId + | extSndId == prevExtSndId = MsgError MsgDuplicate -- ? deduplicate + | extSndId > prevExtSndId + 1 = MsgError $ MsgSkipped (prevExtSndId + 1) (extSndId - 1) + | internalPrevMsgHash /= receivedPrevMsgHash = MsgError MsgBadHash + | otherwise = MsgError MsgDuplicate -- this case is not possible + +connectToSendQueue :: AgentMonad m => AgentClient -> SQLiteStore -> SndQueue -> SenderPublicKey -> VerificationKey -> m () +connectToSendQueue c st sq senderKey verifyKey = do + sendConfirmation c sq senderKey + withStore $ setSndQueueStatus st sq Confirmed + sendHello c sq verifyKey + withStore $ setSndQueueStatus st sq Active + +newSendQueue :: + (MonadUnliftIO m, MonadReader Env m) => SMPQueueInfo -> ConnAlias -> m (SndQueue, SenderPublicKey, VerificationKey) +newSendQueue (SMPQueueInfo smpServer senderId encryptKey) connAlias = do + size <- asks $ rsaKeySize . config + (senderKey, sndPrivateKey) <- liftIO $ C.generateKeyPair size + (verifyKey, signKey) <- liftIO $ C.generateKeyPair size + let sndQueue = + SndQueue + { server = smpServer, + sndId = senderId, + connAlias, + sndPrivateKey, + encryptKey, + signKey, + status = New + } + return (sndQueue, senderKey, verifyKey) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs new file mode 100644 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Simplex.Messaging.Agent.Client + ( AgentClient (..), + newAgentClient, + AgentMonad, + getSMPServerClient, + closeSMPServerClients, + newReceiveQueue, + subscribeQueue, + sendConfirmation, + sendHello, + secureQueue, + sendAgentMessage, + decryptAndVerify, + verifyMessage, + sendAck, + suspendQueue, + deleteQueue, + logServer, + removeSubscription, + cryptoError, + ) +where + +import Control.Logger.Simple +import Control.Monad.Except +import Control.Monad.IO.Unlift +import Control.Monad.Reader +import Control.Monad.Trans.Except +import Data.ByteString.Base64 +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Set (Set) +import qualified Data.Set as S +import Data.Text.Encoding +import Data.Time.Clock +import Simplex.Messaging.Agent.Env.SQLite +import Simplex.Messaging.Agent.Protocol +import Simplex.Messaging.Agent.Store +import Simplex.Messaging.Client +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgBody, QueueId, SenderPublicKey) +import Simplex.Messaging.Util (bshow, liftEitherError, liftError) +import UnliftIO.Concurrent +import UnliftIO.Exception (IOException) +import qualified UnliftIO.Exception as E +import UnliftIO.STM + +data AgentClient = AgentClient + { rcvQ :: TBQueue (ATransmission 'Client), + sndQ :: TBQueue (ATransmission 'Agent), + msgQ :: TBQueue SMPServerTransmission, + smpClients :: TVar (Map SMPServer SMPClient), + subscrSrvrs :: TVar (Map SMPServer (Set ConnAlias)), + subscrConns :: TVar (Map ConnAlias SMPServer), + clientId :: Int + } + +newAgentClient :: TVar Int -> AgentConfig -> STM AgentClient +newAgentClient cc AgentConfig {tbqSize} = do + rcvQ <- newTBQueue tbqSize + sndQ <- newTBQueue tbqSize + msgQ <- newTBQueue tbqSize + smpClients <- newTVar M.empty + subscrSrvrs <- newTVar M.empty + subscrConns <- newTVar M.empty + clientId <- (+ 1) <$> readTVar cc + writeTVar cc clientId + return AgentClient {rcvQ, sndQ, msgQ, smpClients, subscrSrvrs, subscrConns, clientId} + +type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m) + +getSMPServerClient :: forall m. AgentMonad m => AgentClient -> SMPServer -> m SMPClient +getSMPServerClient c@AgentClient {smpClients, msgQ} srv = + readTVarIO smpClients + >>= maybe newSMPClient return . M.lookup srv + where + newSMPClient :: m SMPClient + newSMPClient = do + smp <- connectClient + logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv + atomically . modifyTVar smpClients $ M.insert srv smp + return smp + + connectClient :: m SMPClient + connectClient = do + cfg <- asks $ smpCfg . config + liftEitherError smpClientError (getSMPClient srv cfg msgQ clientDisconnected) + `E.catch` internalError + where + internalError :: IOException -> m SMPClient + internalError = throwError . INTERNAL . show + + clientDisconnected :: IO () + clientDisconnected = do + removeSubs >>= mapM_ (mapM_ notifySub) + logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv + + removeSubs :: IO (Maybe (Set ConnAlias)) + removeSubs = atomically $ do + modifyTVar smpClients $ M.delete srv + cs <- M.lookup srv <$> readTVar (subscrSrvrs c) + modifyTVar (subscrSrvrs c) $ M.delete srv + modifyTVar (subscrConns c) $ maybe id deleteKeys cs + return cs + where + deleteKeys :: Ord k => Set k -> Map k a -> Map k a + deleteKeys ks m = S.foldr' M.delete m ks + + notifySub :: ConnAlias -> IO () + notifySub connAlias = atomically $ writeTBQueue (sndQ c) ("", connAlias, END) + +closeSMPServerClients :: MonadUnliftIO m => AgentClient -> m () +closeSMPServerClients c = liftIO $ readTVarIO (smpClients c) >>= mapM_ closeSMPClient + +withSMP_ :: forall a m. AgentMonad m => AgentClient -> SMPServer -> (SMPClient -> m a) -> m a +withSMP_ c srv action = + (getSMPServerClient c srv >>= action) `catchError` logServerError + where + logServerError :: AgentErrorType -> m a + logServerError e = do + logServer "<--" c srv "" $ bshow e + throwError e + +withLogSMP_ :: AgentMonad m => AgentClient -> SMPServer -> QueueId -> ByteString -> (SMPClient -> m a) -> m a +withLogSMP_ c srv qId cmdStr action = do + logServer "-->" c srv qId cmdStr + res <- withSMP_ c srv action + logServer "<--" c srv qId "OK" + return res + +withSMP :: AgentMonad m => AgentClient -> SMPServer -> (SMPClient -> ExceptT SMPClientError IO a) -> m a +withSMP c srv action = withSMP_ c srv $ liftSMP . action + +withLogSMP :: AgentMonad m => AgentClient -> SMPServer -> QueueId -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> m a +withLogSMP c srv qId cmdStr action = withLogSMP_ c srv qId cmdStr $ liftSMP . action + +liftSMP :: AgentMonad m => ExceptT SMPClientError IO a -> m a +liftSMP = liftError smpClientError + +smpClientError :: SMPClientError -> AgentErrorType +smpClientError = \case + SMPServerError e -> SMP e + SMPResponseError e -> BROKER $ RESPONSE e + SMPUnexpectedResponse -> BROKER UNEXPECTED + SMPResponseTimeout -> BROKER TIMEOUT + SMPNetworkError -> BROKER NETWORK + SMPTransportError e -> BROKER $ TRANSPORT e + e -> INTERNAL $ show e + +newReceiveQueue :: AgentMonad m => AgentClient -> SMPServer -> ConnAlias -> m (RcvQueue, SMPQueueInfo) +newReceiveQueue c srv connAlias = do + size <- asks $ rsaKeySize . config + (recipientKey, rcvPrivateKey) <- liftIO $ C.generateKeyPair size + logServer "-->" c srv "" "NEW" + (rcvId, sId) <- withSMP c srv $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey + logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sId] + (encryptKey, decryptKey) <- liftIO $ C.generateKeyPair size + let rq = + RcvQueue + { server = srv, + rcvId, + connAlias, + rcvPrivateKey, + sndId = Just sId, + sndKey = Nothing, + decryptKey, + verifyKey = Nothing, + status = New + } + addSubscription c rq connAlias + return (rq, SMPQueueInfo srv sId encryptKey) + +subscribeQueue :: AgentMonad m => AgentClient -> RcvQueue -> ConnAlias -> m () +subscribeQueue c rq@RcvQueue {server, rcvPrivateKey, rcvId} connAlias = do + withLogSMP c server rcvId "SUB" $ \smp -> + subscribeSMPQueue smp rcvPrivateKey rcvId + addSubscription c rq connAlias + +addSubscription :: MonadUnliftIO m => AgentClient -> RcvQueue -> ConnAlias -> m () +addSubscription c RcvQueue {server} connAlias = atomically $ do + modifyTVar (subscrConns c) $ M.insert connAlias server + modifyTVar (subscrSrvrs c) $ M.alter (Just . addSub) server + where + addSub :: Maybe (Set ConnAlias) -> Set ConnAlias + addSub (Just cs) = S.insert connAlias cs + addSub _ = S.singleton connAlias + +removeSubscription :: AgentMonad m => AgentClient -> ConnAlias -> m () +removeSubscription AgentClient {subscrConns, subscrSrvrs} connAlias = atomically $ do + cs <- readTVar subscrConns + writeTVar subscrConns $ M.delete connAlias cs + mapM_ + (modifyTVar subscrSrvrs . M.alter (>>= delSub)) + (M.lookup connAlias cs) + where + delSub :: Set ConnAlias -> Maybe (Set ConnAlias) + delSub cs = + let cs' = S.delete connAlias cs + in if S.null cs' then Nothing else Just cs' + +logServer :: AgentMonad m => ByteString -> AgentClient -> SMPServer -> QueueId -> ByteString -> m () +logServer dir AgentClient {clientId} srv qId cmdStr = + logInfo . decodeUtf8 $ B.unwords ["A", "(" <> bshow clientId <> ")", dir, showServer srv, ":", logSecret qId, cmdStr] + +showServer :: SMPServer -> ByteString +showServer srv = B.pack $ host srv <> maybe "" (":" <>) (port srv) + +logSecret :: ByteString -> ByteString +logSecret bs = encode $ B.take 3 bs + +sendConfirmation :: forall m. AgentMonad m => AgentClient -> SndQueue -> SenderPublicKey -> m () +sendConfirmation c sq@SndQueue {server, sndId} senderKey = + withLogSMP_ c server sndId "SEND " $ \smp -> do + msg <- mkConfirmation smp + liftSMP $ sendSMPMessage smp Nothing sndId msg + where + mkConfirmation :: SMPClient -> m MsgBody + mkConfirmation smp = encryptAndSign smp sq . serializeSMPMessage $ SMPConfirmation senderKey + +sendHello :: forall m. AgentMonad m => AgentClient -> SndQueue -> VerificationKey -> m () +sendHello c sq@SndQueue {server, sndId, sndPrivateKey} verifyKey = + withLogSMP_ c server sndId "SEND (retrying)" $ \smp -> do + msg <- mkHello smp $ AckMode On + liftSMP $ send 8 100000 msg smp + where + mkHello :: SMPClient -> AckMode -> m ByteString + mkHello smp ackMode = do + senderTimestamp <- liftIO getCurrentTime + encryptAndSign smp sq . serializeSMPMessage $ + SMPMessage + { senderMsgId = 0, + senderTimestamp, + previousMsgHash = "", + agentMessage = HELLO verifyKey ackMode + } + + send :: Int -> Int -> ByteString -> SMPClient -> ExceptT SMPClientError IO () + send 0 _ _ _ = throwE $ SMPServerError AUTH + send retry delay msg smp = + sendSMPMessage smp (Just sndPrivateKey) sndId msg `catchE` \case + SMPServerError AUTH -> do + threadDelay delay + send (retry - 1) (delay * 3 `div` 2) msg smp + e -> throwE e + +secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SenderPublicKey -> m () +secureQueue c RcvQueue {server, rcvId, rcvPrivateKey} senderKey = + withLogSMP c server rcvId "KEY " $ \smp -> + secureSMPQueue smp rcvPrivateKey rcvId senderKey + +sendAck :: AgentMonad m => AgentClient -> RcvQueue -> m () +sendAck c RcvQueue {server, rcvId, rcvPrivateKey} = + withLogSMP c server rcvId "ACK" $ \smp -> + ackSMPMessage smp rcvPrivateKey rcvId + +suspendQueue :: AgentMonad m => AgentClient -> RcvQueue -> m () +suspendQueue c RcvQueue {server, rcvId, rcvPrivateKey} = + withLogSMP c server rcvId "OFF" $ \smp -> + suspendSMPQueue smp rcvPrivateKey rcvId + +deleteQueue :: AgentMonad m => AgentClient -> RcvQueue -> m () +deleteQueue c RcvQueue {server, rcvId, rcvPrivateKey} = + withLogSMP c server rcvId "DEL" $ \smp -> + deleteSMPQueue smp rcvPrivateKey rcvId + +sendAgentMessage :: AgentMonad m => AgentClient -> SndQueue -> ByteString -> m () +sendAgentMessage c sq@SndQueue {server, sndId, sndPrivateKey} msg = + withLogSMP_ c server sndId "SEND " $ \smp -> do + msg' <- encryptAndSign smp sq msg + liftSMP $ sendSMPMessage smp (Just sndPrivateKey) sndId msg' + +encryptAndSign :: AgentMonad m => SMPClient -> SndQueue -> ByteString -> m ByteString +encryptAndSign smp SndQueue {encryptKey, signKey} msg = do + paddedSize <- asks $ (blockSize smp -) . reservedMsgSize + liftError cryptoError $ do + enc <- C.encrypt encryptKey paddedSize msg + C.Signature sig <- C.sign signKey enc + pure $ sig <> enc + +decryptAndVerify :: AgentMonad m => RcvQueue -> ByteString -> m ByteString +decryptAndVerify RcvQueue {decryptKey, verifyKey} msg = + verifyMessage verifyKey msg + >>= liftError cryptoError . C.decrypt decryptKey + +verifyMessage :: AgentMonad m => Maybe VerificationKey -> ByteString -> m ByteString +verifyMessage verifyKey msg = do + size <- asks $ rsaKeySize . config + let (sig, enc) = B.splitAt size msg + case verifyKey of + Nothing -> pure enc + Just k + | C.verify k (C.Signature sig) enc -> pure enc + | otherwise -> throwError $ AGENT A_SIGNATURE + +cryptoError :: C.CryptoError -> AgentErrorType +cryptoError = \case + C.CryptoLargeMsgError -> CMD LARGE + C.RSADecryptError _ -> AGENT A_ENCRYPTION + C.CryptoHeaderError _ -> AGENT A_ENCRYPTION + C.AESDecryptError -> AGENT A_ENCRYPTION + e -> INTERNAL $ show e diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs new file mode 100644 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} + +module Simplex.Messaging.Agent.Env.SQLite where + +import Control.Monad.IO.Unlift +import Crypto.Random +import Data.List.NonEmpty (NonEmpty) +import Network.Socket +import Numeric.Natural +import Simplex.Messaging.Agent.Protocol (SMPServer) +import Simplex.Messaging.Agent.Store.SQLite +import Simplex.Messaging.Client +import System.Random (StdGen, newStdGen) +import UnliftIO.STM + +data AgentConfig = AgentConfig + { tcpPort :: ServiceName, + smpServers :: NonEmpty SMPServer, + rsaKeySize :: Int, + connIdBytes :: Int, + tbqSize :: Natural, + dbFile :: FilePath, + smpCfg :: SMPClientConfig + } + +data Env = Env + { config :: AgentConfig, + idsDrg :: TVar ChaChaDRG, + clientCounter :: TVar Int, + reservedMsgSize :: Int, + randomServer :: TVar StdGen + } + +newSMPAgentEnv :: (MonadUnliftIO m, MonadRandom m) => AgentConfig -> m Env +newSMPAgentEnv config = do + idsDrg <- newTVarIO =<< drgNew + _ <- createSQLiteStore $ dbFile config + clientCounter <- newTVarIO 0 + randomServer <- newTVarIO =<< liftIO newStdGen + return Env {config, idsDrg, clientCounter, reservedMsgSize, randomServer} + where + -- 1st rsaKeySize is used by the RSA signature in each command, + -- 2nd - by encrypted message body header + -- 3rd - by message signature + -- smpCommandSize - is the estimated max size for SMP command, queueId, corrId + reservedMsgSize = 3 * rsaKeySize config + smpCommandSize (smpCfg config) diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -0,0 +1,601 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} + +-- | +-- Module : Simplex.Messaging.Agent.Protocol +-- Copyright : (c) simplex.chat +-- License : AGPL-3 +-- +-- Maintainer : chat@simplex.chat +-- Stability : experimental +-- Portability : non-portable +-- +-- Types, parsers, serializers and functions to send and receive SMP agent protocol commands and responses. +-- +-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md +module Simplex.Messaging.Agent.Protocol + ( -- * SMP agent protocol types + ACommand (..), + AParty (..), + SAParty (..), + SMPMessage (..), + AMessage (..), + SMPServer (..), + SMPQueueInfo (..), + AgentErrorType (..), + CommandErrorType (..), + ConnectionErrorType (..), + BrokerErrorType (..), + SMPAgentError (..), + ATransmission, + ATransmissionOrError, + ARawTransmission, + ConnAlias, + ReplyMode (..), + AckMode (..), + OnOff (..), + MsgIntegrity (..), + MsgErrorType (..), + QueueStatus (..), + SignatureKey, + VerificationKey, + EncryptionKey, + DecryptionKey, + + -- * Parse and serialize + serializeCommand, + serializeSMPMessage, + serializeMsgIntegrity, + serializeServer, + serializeSmpQueueInfo, + serializeAgentError, + commandP, + parseSMPMessage, + smpServerP, + smpQueueInfoP, + msgIntegrityP, + agentErrorTypeP, + + -- * TCP transport functions + tPut, + tGet, + tPutRaw, + tGetRaw, + ) +where + +import Control.Applicative (optional, (<|>)) +import Control.Monad.IO.Class +import Data.Attoparsec.ByteString.Char8 (Parser) +import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.ByteString.Base64 +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Functor (($>)) +import Data.Int (Int64) +import Data.Kind (Type) +import Data.String (IsString (..)) +import Data.Time.Clock (UTCTime) +import Data.Time.ISO8601 +import Data.Type.Equality +import Data.Typeable () +import GHC.Generics (Generic) +import Generic.Random (genericArbitraryU) +import Network.Socket +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Parsers +import Simplex.Messaging.Protocol + ( CorrId (..), + ErrorType, + MsgBody, + MsgId, + SenderPublicKey, + ) +import qualified Simplex.Messaging.Protocol as SMP +import Simplex.Messaging.Transport (TransportError, getLn, putLn, serializeTransportError, transportErrorP) +import Simplex.Messaging.Util +import System.IO +import Test.QuickCheck (Arbitrary (..)) +import Text.Read +import UnliftIO.Exception + +-- | Raw (unparsed) SMP agent protocol transmission. +type ARawTransmission = (ByteString, ByteString, ByteString) + +-- | Parsed SMP agent protocol transmission. +type ATransmission p = (CorrId, ConnAlias, ACommand p) + +-- | SMP agent protocol transmission or transmission error. +type ATransmissionOrError p = (CorrId, ConnAlias, Either AgentErrorType (ACommand p)) + +-- | SMP agent protocol participants. +data AParty = Agent | Client + deriving (Eq, Show) + +-- | Singleton types for SMP agent protocol participants. +data SAParty :: AParty -> Type where + SAgent :: SAParty Agent + SClient :: SAParty Client + +deriving instance Show (SAParty p) + +deriving instance Eq (SAParty p) + +instance TestEquality SAParty where + testEquality SAgent SAgent = Just Refl + testEquality SClient SClient = Just Refl + testEquality _ _ = Nothing + +data ACmd = forall p. ACmd (SAParty p) (ACommand p) + +deriving instance Show ACmd + +-- | Parameterized type for SMP agent protocol commands and responses from all participants. +data ACommand (p :: AParty) where + NEW :: ACommand Client -- response INV + INV :: SMPQueueInfo -> ACommand Agent + JOIN :: SMPQueueInfo -> ReplyMode -> ACommand Client -- response OK + CON :: ACommand Agent -- notification that connection is established + -- TODO currently it automatically allows whoever sends the confirmation + -- CONF :: OtherPartyId -> ACommand Agent + -- LET :: OtherPartyId -> ACommand Client + SUB :: ACommand Client + SUBALL :: ACommand Client -- TODO should be moved to chat protocol - hack for subscribing to all + END :: ACommand Agent + -- QST :: QueueDirection -> ACommand Client + -- STAT :: QueueDirection -> Maybe QueueStatus -> Maybe SubMode -> ACommand Agent + SEND :: MsgBody -> ACommand Client + SENT :: AgentMsgId -> ACommand Agent + MSG :: + { recipientMeta :: (AgentMsgId, UTCTime), + brokerMeta :: (MsgId, UTCTime), + senderMeta :: (AgentMsgId, UTCTime), + msgIntegrity :: MsgIntegrity, + msgBody :: MsgBody + } -> + ACommand Agent + -- ACK :: AgentMsgId -> ACommand Client + -- RCVD :: AgentMsgId -> ACommand Agent + OFF :: ACommand Client + DEL :: ACommand Client + OK :: ACommand Agent + ERR :: AgentErrorType -> ACommand Agent + +deriving instance Eq (ACommand p) + +deriving instance Show (ACommand p) + +-- | SMP message formats. +data SMPMessage + = -- | SMP confirmation + -- (see ) + SMPConfirmation SenderPublicKey + | -- | Agent message header and envelope for client messages + -- (see ) + SMPMessage + { -- | sequential ID assigned by the sending agent + senderMsgId :: AgentMsgId, + -- | timestamp from the sending agent + senderTimestamp :: SenderTimestamp, + -- | digest of the previous message + previousMsgHash :: ByteString, + -- | messages sent between agents once queue is secured + agentMessage :: AMessage + } + deriving (Show) + +-- | Messages sent between SMP agents once SMP queue is secured. +-- +-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md#messages-between-smp-agents +data AMessage where + -- | the first message in the queue to validate it is secured + HELLO :: VerificationKey -> AckMode -> AMessage + -- | reply queue information + REPLY :: SMPQueueInfo -> AMessage + -- | agent envelope for the client message + A_MSG :: MsgBody -> AMessage + deriving (Show) + +-- | Parse SMP message. +parseSMPMessage :: ByteString -> Either AgentErrorType SMPMessage +parseSMPMessage = parse (smpMessageP <* A.endOfLine) $ AGENT A_MESSAGE + where + smpMessageP :: Parser SMPMessage + smpMessageP = + smpConfirmationP <* A.endOfLine + <|> A.endOfLine *> smpClientMessageP + + smpConfirmationP :: Parser SMPMessage + smpConfirmationP = SMPConfirmation <$> ("KEY " *> C.pubKeyP <* A.endOfLine) + + smpClientMessageP :: Parser SMPMessage + smpClientMessageP = + SMPMessage + <$> A.decimal <* A.space + <*> tsISO8601P <* A.space + -- TODO previous message hash should become mandatory when we support HELLO and REPLY + -- (for HELLO it would be the hash of SMPConfirmation) + <*> (base64P <|> pure "") <* A.endOfLine + <*> agentMessageP + +-- | Serialize SMP message. +serializeSMPMessage :: SMPMessage -> ByteString +serializeSMPMessage = \case + SMPConfirmation sKey -> smpMessage ("KEY " <> C.serializePubKey sKey) "" "" + SMPMessage {senderMsgId, senderTimestamp, previousMsgHash, agentMessage} -> + let header = messageHeader senderMsgId senderTimestamp previousMsgHash + body = serializeAgentMessage agentMessage + in smpMessage "" header body + where + messageHeader msgId ts prevMsgHash = + B.unwords [bshow msgId, B.pack $ formatISO8601Millis ts, encode prevMsgHash] + smpMessage smpHeader aHeader aBody = B.intercalate "\n" [smpHeader, aHeader, aBody, ""] + +agentMessageP :: Parser AMessage +agentMessageP = + "HELLO " *> hello + <|> "REPLY " *> reply + <|> "MSG " *> a_msg + where + hello = HELLO <$> C.pubKeyP <*> ackMode + reply = REPLY <$> smpQueueInfoP + a_msg = do + size :: Int <- A.decimal <* A.endOfLine + A_MSG <$> A.take size <* A.endOfLine + ackMode = AckMode <$> (" NO_ACK" $> Off <|> pure On) + +-- | SMP queue information parser. +smpQueueInfoP :: Parser SMPQueueInfo +smpQueueInfoP = + "smp::" *> (SMPQueueInfo <$> smpServerP <* "::" <*> base64P <* "::" <*> C.pubKeyP) + +-- | SMP server location parser. +smpServerP :: Parser SMPServer +smpServerP = SMPServer <$> server <*> optional port <*> optional kHash + where + server = B.unpack <$> A.takeWhile1 (A.notInClass ":# ") + port = A.char ':' *> (B.unpack <$> A.takeWhile1 A.isDigit) + kHash = C.KeyHash <$> (A.char '#' *> base64P) + +serializeAgentMessage :: AMessage -> ByteString +serializeAgentMessage = \case + HELLO verifyKey ackMode -> "HELLO " <> C.serializePubKey verifyKey <> if ackMode == AckMode Off then " NO_ACK" else "" + REPLY qInfo -> "REPLY " <> serializeSmpQueueInfo qInfo + A_MSG body -> "MSG " <> serializeMsg body <> "\n" + +-- | Serialize SMP queue information that is sent out-of-band. +serializeSmpQueueInfo :: SMPQueueInfo -> ByteString +serializeSmpQueueInfo (SMPQueueInfo srv qId ek) = + B.intercalate "::" ["smp", serializeServer srv, encode qId, C.serializePubKey ek] + +-- | Serialize SMP server location. +serializeServer :: SMPServer -> ByteString +serializeServer SMPServer {host, port, keyHash} = + B.pack $ host <> maybe "" (':' :) port <> maybe "" (('#' :) . B.unpack . encode . C.unKeyHash) keyHash + +-- | SMP server location and transport key digest (hash). +data SMPServer = SMPServer + { host :: HostName, + port :: Maybe ServiceName, + keyHash :: Maybe C.KeyHash + } + deriving (Eq, Ord, Show) + +instance IsString SMPServer where + fromString = parseString . parseAll $ smpServerP + +-- | SMP agent connection alias. +type ConnAlias = ByteString + +-- | Connection modes. +data OnOff = On | Off deriving (Eq, Show, Read) + +-- | Message acknowledgement mode of the connection. +newtype AckMode = AckMode OnOff deriving (Eq, Show) + +-- | SMP queue information sent out-of-band. +-- +-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#out-of-band-messages +data SMPQueueInfo = SMPQueueInfo SMPServer SMP.SenderId EncryptionKey + deriving (Eq, Show) + +-- | Connection reply mode (used in JOIN command). +newtype ReplyMode = ReplyMode OnOff deriving (Eq, Show) + +-- | Public key used to E2E encrypt SMP messages. +type EncryptionKey = C.PublicKey + +-- | Private key used to E2E decrypt SMP messages. +type DecryptionKey = C.SafePrivateKey + +-- | Private key used to sign SMP commands +type SignatureKey = C.SafePrivateKey + +-- | Public key used by SMP server to authorize (verify) SMP commands. +type VerificationKey = C.PublicKey + +data QueueDirection = SND | RCV deriving (Show) + +-- | SMP queue status. +data QueueStatus + = -- | queue is created + New + | -- | queue is confirmed by the sender + Confirmed + | -- | queue is secured with sender key (only used by the queue recipient) + Secured + | -- | queue is active + Active + | -- | queue is disabled (only used by the queue recipient) + Disabled + deriving (Eq, Show, Read) + +type AgentMsgId = Int64 + +type SenderTimestamp = UTCTime + +-- | Result of received message integrity validation. +data MsgIntegrity = MsgOk | MsgError MsgErrorType + deriving (Eq, Show) + +-- | Error of message integrity validation. +data MsgErrorType = MsgSkipped AgentMsgId AgentMsgId | MsgBadId AgentMsgId | MsgBadHash | MsgDuplicate + deriving (Eq, Show) + +-- | Error type used in errors sent to agent clients. +data AgentErrorType + = -- | command or response error + CMD CommandErrorType + | -- | connection errors + CONN ConnectionErrorType + | -- | SMP protocol errors forwarded to agent clients + SMP ErrorType + | -- | SMP server errors + BROKER BrokerErrorType + | -- | errors of other agents + AGENT SMPAgentError + | -- | agent implementation or dependency errors + INTERNAL String + deriving (Eq, Generic, Read, Show, Exception) + +-- | SMP agent protocol command or response error. +data CommandErrorType + = -- | command is prohibited + PROHIBITED + | -- | command syntax is invalid + SYNTAX + | -- | connection alias is required with this command + NO_CONN + | -- | message size is not correct (no terminating space) + SIZE + | -- | message does not fit in SMP block + LARGE + deriving (Eq, Generic, Read, Show, Exception) + +-- | Connection error. +data ConnectionErrorType + = -- | connection alias is not in the database + UNKNOWN + | -- | connection alias already exists + DUPLICATE + | -- | connection is simplex, but operation requires another queue + SIMPLEX + deriving (Eq, Generic, Read, Show, Exception) + +-- | SMP server errors. +data BrokerErrorType + = -- | invalid server response (failed to parse) + RESPONSE ErrorType + | -- | unexpected response + UNEXPECTED + | -- | network error + NETWORK + | -- | handshake or other transport error + TRANSPORT TransportError + | -- | command response timeout + TIMEOUT + deriving (Eq, Generic, Read, Show, Exception) + +-- | Errors of another SMP agent. +data SMPAgentError + = -- | possibly should include bytestring that failed to parse + A_MESSAGE + | -- | possibly should include the prohibited SMP/agent message + A_PROHIBITED + | -- | cannot RSA/AES-decrypt or parse decrypted header + A_ENCRYPTION + | -- | invalid RSA signature + A_SIGNATURE + deriving (Eq, Generic, Read, Show, Exception) + +instance Arbitrary AgentErrorType where arbitrary = genericArbitraryU + +instance Arbitrary CommandErrorType where arbitrary = genericArbitraryU + +instance Arbitrary ConnectionErrorType where arbitrary = genericArbitraryU + +instance Arbitrary BrokerErrorType where arbitrary = genericArbitraryU + +instance Arbitrary SMPAgentError where arbitrary = genericArbitraryU + +-- | AMP agent command and response parser +commandP :: Parser ACmd +commandP = + "NEW" $> ACmd SClient NEW + <|> "INV " *> invResp + <|> "JOIN " *> joinCmd + <|> "SUB" $> ACmd SClient SUB + <|> "SUBALL" $> ACmd SClient SUBALL -- TODO remove - hack for subscribing to all + <|> "END" $> ACmd SAgent END + <|> "SEND " *> sendCmd + <|> "SENT " *> sentResp + <|> "MSG " *> message + <|> "OFF" $> ACmd SClient OFF + <|> "DEL" $> ACmd SClient DEL + <|> "ERR " *> agentError + <|> "CON" $> ACmd SAgent CON + <|> "OK" $> ACmd SAgent OK + where + invResp = ACmd SAgent . INV <$> smpQueueInfoP + joinCmd = ACmd SClient <$> (JOIN <$> smpQueueInfoP <*> replyMode) + sendCmd = ACmd SClient . SEND <$> A.takeByteString + sentResp = ACmd SAgent . SENT <$> A.decimal + message = do + msgIntegrity <- msgIntegrityP <* A.space + recipientMeta <- "R=" *> partyMeta A.decimal + brokerMeta <- "B=" *> partyMeta base64P + senderMeta <- "S=" *> partyMeta A.decimal + msgBody <- A.takeByteString + return $ ACmd SAgent MSG {recipientMeta, brokerMeta, senderMeta, msgIntegrity, msgBody} + replyMode = ReplyMode <$> (" NO_REPLY" $> Off <|> pure On) + partyMeta idParser = (,) <$> idParser <* "," <*> tsISO8601P <* A.space + agentError = ACmd SAgent . ERR <$> agentErrorTypeP + +-- | Message integrity validation result parser. +msgIntegrityP :: Parser MsgIntegrity +msgIntegrityP = "OK" $> MsgOk <|> "ERR " *> (MsgError <$> msgErrorType) + where + msgErrorType = + "ID " *> (MsgBadId <$> A.decimal) + <|> "IDS " *> (MsgSkipped <$> A.decimal <* A.space <*> A.decimal) + <|> "HASH" $> MsgBadHash + <|> "DUPLICATE" $> MsgDuplicate + +parseCommand :: ByteString -> Either AgentErrorType ACmd +parseCommand = parse commandP $ CMD SYNTAX + +-- | Serialize SMP agent command. +serializeCommand :: ACommand p -> ByteString +serializeCommand = \case + NEW -> "NEW" + INV qInfo -> "INV " <> serializeSmpQueueInfo qInfo + JOIN qInfo rMode -> "JOIN " <> serializeSmpQueueInfo qInfo <> replyMode rMode + SUB -> "SUB" + SUBALL -> "SUBALL" -- TODO remove - hack for subscribing to all + END -> "END" + SEND msgBody -> "SEND " <> serializeMsg msgBody + SENT mId -> "SENT " <> bshow mId + MSG {recipientMeta = (rmId, rTs), brokerMeta = (bmId, bTs), senderMeta = (smId, sTs), msgIntegrity, msgBody} -> + B.unwords + [ "MSG", + serializeMsgIntegrity msgIntegrity, + "R=" <> bshow rmId <> "," <> showTs rTs, + "B=" <> encode bmId <> "," <> showTs bTs, + "S=" <> bshow smId <> "," <> showTs sTs, + serializeMsg msgBody + ] + OFF -> "OFF" + DEL -> "DEL" + CON -> "CON" + ERR e -> "ERR " <> serializeAgentError e + OK -> "OK" + where + replyMode :: ReplyMode -> ByteString + replyMode = \case + ReplyMode Off -> " NO_REPLY" + ReplyMode On -> "" + showTs :: UTCTime -> ByteString + showTs = B.pack . formatISO8601Millis + +-- | Serialize message integrity validation result. +serializeMsgIntegrity :: MsgIntegrity -> ByteString +serializeMsgIntegrity = \case + MsgOk -> "OK" + MsgError e -> + "ERR " <> case e of + MsgSkipped fromMsgId toMsgId -> + B.unwords ["NO_ID", bshow fromMsgId, bshow toMsgId] + MsgBadId aMsgId -> "ID " <> bshow aMsgId + MsgBadHash -> "HASH" + MsgDuplicate -> "DUPLICATE" + +-- | SMP agent protocol error parser. +agentErrorTypeP :: Parser AgentErrorType +agentErrorTypeP = + "SMP " *> (SMP <$> SMP.errorTypeP) + <|> "BROKER RESPONSE " *> (BROKER . RESPONSE <$> SMP.errorTypeP) + <|> "BROKER TRANSPORT " *> (BROKER . TRANSPORT <$> transportErrorP) + <|> "INTERNAL " *> (INTERNAL <$> parseRead A.takeByteString) + <|> parseRead2 + +-- | Serialize SMP agent protocol error. +serializeAgentError :: AgentErrorType -> ByteString +serializeAgentError = \case + SMP e -> "SMP " <> SMP.serializeErrorType e + BROKER (RESPONSE e) -> "BROKER RESPONSE " <> SMP.serializeErrorType e + BROKER (TRANSPORT e) -> "BROKER TRANSPORT " <> serializeTransportError e + e -> bshow e + +serializeMsg :: ByteString -> ByteString +serializeMsg body = bshow (B.length body) <> "\n" <> body + +-- | Send raw (unparsed) SMP agent protocol transmission to TCP connection. +tPutRaw :: Handle -> ARawTransmission -> IO () +tPutRaw h (corrId, connAlias, command) = do + putLn h corrId + putLn h connAlias + putLn h command + +-- | Receive raw (unparsed) SMP agent protocol transmission from TCP connection. +tGetRaw :: Handle -> IO ARawTransmission +tGetRaw h = (,,) <$> getLn h <*> getLn h <*> getLn h + +-- | Send SMP agent protocol command (or response) to TCP connection. +tPut :: MonadIO m => Handle -> ATransmission p -> m () +tPut h (CorrId corrId, connAlias, command) = + liftIO $ tPutRaw h (corrId, connAlias, serializeCommand command) + +-- | Receive client and agent transmissions from TCP connection. +tGet :: forall m p. MonadIO m => SAParty p -> Handle -> m (ATransmissionOrError p) +tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody + where + tParseLoadBody :: ARawTransmission -> m (ATransmissionOrError p) + tParseLoadBody t@(corrId, connAlias, command) = do + let cmd = parseCommand command >>= fromParty >>= tConnAlias t + fullCmd <- either (return . Left) cmdWithMsgBody cmd + return (CorrId corrId, connAlias, fullCmd) + + fromParty :: ACmd -> Either AgentErrorType (ACommand p) + fromParty (ACmd (p :: p1) cmd) = case testEquality party p of + Just Refl -> Right cmd + _ -> Left $ CMD PROHIBITED + + tConnAlias :: ARawTransmission -> ACommand p -> Either AgentErrorType (ACommand p) + tConnAlias (_, connAlias, _) cmd = case cmd of + -- NEW and JOIN have optional connAlias + NEW -> Right cmd + JOIN _ _ -> Right cmd + -- ERROR response does not always have connAlias + ERR _ -> Right cmd + -- other responses must have connAlias + _ + | B.null connAlias -> Left $ CMD NO_CONN + | otherwise -> Right cmd + + cmdWithMsgBody :: ACommand p -> m (Either AgentErrorType (ACommand p)) + cmdWithMsgBody = \case + SEND body -> SEND <$$> getMsgBody body + MSG agentMsgId srvTS agentTS integrity body -> MSG agentMsgId srvTS agentTS integrity <$$> getMsgBody body + cmd -> return $ Right cmd + + -- TODO refactor with server + getMsgBody :: MsgBody -> m (Either AgentErrorType MsgBody) + getMsgBody msgBody = + case B.unpack msgBody of + ':' : body -> return . Right $ B.pack body + str -> case readMaybe str :: Maybe Int of + Just size -> liftIO $ do + body <- B.hGet h size + s <- getLn h + return $ if B.null s then Right body else Left $ CMD SIZE + Nothing -> return . Left $ CMD SYNTAX diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs new file mode 100644 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} + +module Simplex.Messaging.Agent.Store where + +import Control.Exception (Exception) +import Data.ByteString.Char8 (ByteString) +import Data.Int (Int64) +import Data.Kind (Type) +import Data.Time (UTCTime) +import Data.Type.Equality +import Simplex.Messaging.Agent.Protocol +import Simplex.Messaging.Protocol + ( MsgBody, + MsgId, + RecipientPrivateKey, + SenderPrivateKey, + SenderPublicKey, + ) +import qualified Simplex.Messaging.Protocol as SMP + +-- * Store management + +-- | Store class type. Defines store access methods for implementations. +class Monad m => MonadAgentStore s m where + -- Queue and Connection management + createRcvConn :: s -> RcvQueue -> m () + createSndConn :: s -> SndQueue -> m () + getConn :: s -> ConnAlias -> m SomeConn + getAllConnAliases :: s -> m [ConnAlias] -- TODO remove - hack for subscribing to all + getRcvConn :: s -> SMPServer -> SMP.RecipientId -> m SomeConn + deleteConn :: s -> ConnAlias -> m () + upgradeRcvConnToDuplex :: s -> ConnAlias -> SndQueue -> m () + upgradeSndConnToDuplex :: s -> ConnAlias -> RcvQueue -> m () + setRcvQueueStatus :: s -> RcvQueue -> QueueStatus -> m () + setRcvQueueActive :: s -> RcvQueue -> VerificationKey -> m () + setSndQueueStatus :: s -> SndQueue -> QueueStatus -> m () + + -- Msg management + updateRcvIds :: s -> RcvQueue -> m (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash) + createRcvMsg :: s -> RcvQueue -> RcvMsgData -> m () + + updateSndIds :: s -> SndQueue -> m (InternalId, InternalSndId, PrevSndMsgHash) + createSndMsg :: s -> SndQueue -> SndMsgData -> m () + + getMsg :: s -> ConnAlias -> InternalId -> m Msg + +-- * Queue types + +-- | A receive queue. SMP queue through which the agent receives messages from a sender. +data RcvQueue = RcvQueue + { server :: SMPServer, + rcvId :: SMP.RecipientId, + connAlias :: ConnAlias, + rcvPrivateKey :: RecipientPrivateKey, + sndId :: Maybe SMP.SenderId, + sndKey :: Maybe SenderPublicKey, + decryptKey :: DecryptionKey, + verifyKey :: Maybe VerificationKey, + status :: QueueStatus + } + deriving (Eq, Show) + +-- | A send queue. SMP queue through which the agent sends messages to a recipient. +data SndQueue = SndQueue + { server :: SMPServer, + sndId :: SMP.SenderId, + connAlias :: ConnAlias, + sndPrivateKey :: SenderPrivateKey, + encryptKey :: EncryptionKey, + signKey :: SignatureKey, + status :: QueueStatus + } + deriving (Eq, Show) + +-- * Connection types + +-- | Type of a connection. +data ConnType = CRcv | CSnd | CDuplex deriving (Eq, Show) + +-- | Connection of a specific type. +-- +-- - RcvConnection is a connection that only has a receive queue set up, +-- typically created by a recipient initiating a duplex connection. +-- +-- - SndConnection is a connection that only has a send queue set up, typically +-- created by a sender joining a duplex connection through a recipient's invitation. +-- +-- - DuplexConnection is a connection that has both receive and send queues set up, +-- typically created by upgrading a receive or a send connection with a missing queue. +data Connection (d :: ConnType) where + RcvConnection :: ConnAlias -> RcvQueue -> Connection CRcv + SndConnection :: ConnAlias -> SndQueue -> Connection CSnd + DuplexConnection :: ConnAlias -> RcvQueue -> SndQueue -> Connection CDuplex + +deriving instance Eq (Connection d) + +deriving instance Show (Connection d) + +data SConnType :: ConnType -> Type where + SCRcv :: SConnType CRcv + SCSnd :: SConnType CSnd + SCDuplex :: SConnType CDuplex + +connType :: SConnType c -> ConnType +connType SCRcv = CRcv +connType SCSnd = CSnd +connType SCDuplex = CDuplex + +deriving instance Eq (SConnType d) + +deriving instance Show (SConnType d) + +instance TestEquality SConnType where + testEquality SCRcv SCRcv = Just Refl + testEquality SCSnd SCSnd = Just Refl + testEquality SCDuplex SCDuplex = Just Refl + testEquality _ _ = Nothing + +-- | Connection of an unknown type. +-- Used to refer to an arbitrary connection when retrieving from store. +data SomeConn = forall d. SomeConn (SConnType d) (Connection d) + +instance Eq SomeConn where + SomeConn d c == SomeConn d' c' = case testEquality d d' of + Just Refl -> c == c' + _ -> False + +deriving instance Show SomeConn + +-- * Message integrity validation types + +type MsgHash = ByteString + +-- | Corresponds to `last_external_snd_msg_id` in `connections` table +type PrevExternalSndId = Int64 + +-- | Corresponds to `last_rcv_msg_hash` in `connections` table +type PrevRcvMsgHash = MsgHash + +-- | Corresponds to `last_snd_msg_hash` in `connections` table +type PrevSndMsgHash = MsgHash + +-- ? merge/replace these with RcvMsg and SndMsg + +-- * Message data containers - used on Msg creation to reduce number of parameters + +data RcvMsgData = RcvMsgData + { internalId :: InternalId, + internalRcvId :: InternalRcvId, + internalTs :: InternalTs, + senderMeta :: (ExternalSndId, ExternalSndTs), + brokerMeta :: (BrokerId, BrokerTs), + msgBody :: MsgBody, + internalHash :: MsgHash, + externalPrevSndHash :: MsgHash, + msgIntegrity :: MsgIntegrity + } + +data SndMsgData = SndMsgData + { internalId :: InternalId, + internalSndId :: InternalSndId, + internalTs :: InternalTs, + msgBody :: MsgBody, + internalHash :: MsgHash + } + +-- * Message types + +-- | A message in either direction that is stored by the agent. +data Msg = MRcv RcvMsg | MSnd SndMsg + deriving (Eq, Show) + +-- | A message received by the agent from a sender. +data RcvMsg = RcvMsg + { msgBase :: MsgBase, + internalRcvId :: InternalRcvId, + -- | Id of the message at sender, corresponds to `internalSndId` from the sender's side. + -- Sender Id is made sequential for detection of missing messages. For redundant / parallel queues, + -- it also allows to keep track of duplicates and restore the original order before delivery to the client. + externalSndId :: ExternalSndId, + externalSndTs :: ExternalSndTs, + -- | Id of the message at broker, although it is not sequential (to avoid metadata leakage for potential observer), + -- it is needed to track repeated deliveries in case of connection loss - this logic is not implemented yet. + brokerId :: BrokerId, + brokerTs :: BrokerTs, + rcvMsgStatus :: RcvMsgStatus, + -- | Timestamp of acknowledgement to broker, corresponds to `AcknowledgedToBroker` status. + -- Do not mix up with `brokerTs` - timestamp created at broker after it receives the message from sender. + ackBrokerTs :: AckBrokerTs, + -- | Timestamp of acknowledgement to sender, corresponds to `AcknowledgedToSender` status. + -- Do not mix up with `externalSndTs` - timestamp created at sender before sending, + -- which in its turn corresponds to `internalTs` in sending agent. + ackSenderTs :: AckSenderTs, + -- | Hash of previous message as received from sender - stored for integrity forensics. + externalPrevSndHash :: MsgHash, + msgIntegrity :: MsgIntegrity + } + deriving (Eq, Show) + +-- internal Ids are newtypes to prevent mixing them up +newtype InternalRcvId = InternalRcvId {unRcvId :: Int64} deriving (Eq, Show) + +type ExternalSndId = Int64 + +type ExternalSndTs = UTCTime + +type BrokerId = MsgId + +type BrokerTs = UTCTime + +data RcvMsgStatus + = Received + | AcknowledgedToBroker + | AcknowledgedToSender + deriving (Eq, Show) + +type AckBrokerTs = UTCTime + +type AckSenderTs = UTCTime + +-- | A message sent by the agent to a recipient. +data SndMsg = SndMsg + { msgBase :: MsgBase, + -- | Id of the message sent / to be sent, as in its number in order of sending. + internalSndId :: InternalSndId, + sndMsgStatus :: SndMsgStatus, + -- | Timestamp of the message received by broker, corresponds to `Sent` status. + sentTs :: SentTs, + -- | Timestamp of the message received by recipient, corresponds to `Delivered` status. + deliveredTs :: DeliveredTs + } + deriving (Eq, Show) + +newtype InternalSndId = InternalSndId {unSndId :: Int64} deriving (Eq, Show) + +data SndMsgStatus + = Created + | Sent + | Delivered + deriving (Eq, Show) + +type SentTs = UTCTime + +type DeliveredTs = UTCTime + +-- | Base message data independent of direction. +data MsgBase = MsgBase + { connAlias :: ConnAlias, + -- | Monotonically increasing id of a message per connection, internal to the agent. + -- Internal Id preserves ordering between both received and sent messages, and is needed + -- to track the order of the conversation (which can be different for the sender / receiver) + -- and address messages in commands. External [sender] Id cannot be used for this purpose + -- due to a possibility of implementation errors in different agents. + internalId :: InternalId, + internalTs :: InternalTs, + msgBody :: MsgBody, + -- | Hash of the message as computed by agent. + internalHash :: MsgHash + } + deriving (Eq, Show) + +newtype InternalId = InternalId {unId :: Int64} deriving (Eq, Show) + +type InternalTs = UTCTime + +-- * Store errors + +-- | Agent store error. +data StoreError + = -- | IO exceptions in store actions. + SEInternal ByteString + | -- | Connection alias not found (or both queues absent). + SEConnNotFound + | -- | Connection alias already used. + SEConnDuplicate + | -- | Wrong connection type, e.g. "send" connection when "receive" or "duplex" is expected, or vice versa. + -- 'upgradeRcvConnToDuplex' and 'upgradeSndConnToDuplex' do not allow duplex connections - they would also return this error. + SEBadConnType ConnType + | -- | Currently not used. The intention was to pass current expected queue status in methods, + -- as we always know what it should be at any stage of the protocol, + -- and in case it does not match use this error. + SEBadQueueStatus + | -- | Used in `getMsg` that is not implemented/used. TODO remove. + SENotImplemented + deriving (Eq, Show, Exception) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs new file mode 100644 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -0,0 +1,668 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Simplex.Messaging.Agent.Store.SQLite + ( SQLiteStore (..), + createSQLiteStore, + connectSQLiteStore, + ) +where + +import Control.Concurrent (threadDelay) +import Control.Monad (when) +import Control.Monad.Except (MonadError (throwError), MonadIO (liftIO)) +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Data.Bifunctor (first) +import Data.List (find) +import Data.Maybe (fromMaybe) +import Data.Text (isPrefixOf) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) +import Database.SQLite.Simple (FromRow, NamedParam (..), Only (..), SQLData (..), SQLError, field) +import qualified Database.SQLite.Simple as DB +import Database.SQLite.Simple.FromField +import Database.SQLite.Simple.Internal (Field (..)) +import Database.SQLite.Simple.Ok (Ok (Ok)) +import Database.SQLite.Simple.QQ (sql) +import Database.SQLite.Simple.ToField (ToField (..)) +import Network.Socket (ServiceName) +import Simplex.Messaging.Agent.Protocol +import Simplex.Messaging.Agent.Store +import Simplex.Messaging.Agent.Store.SQLite.Schema (createSchema) +import Simplex.Messaging.Parsers (blobFieldParser) +import qualified Simplex.Messaging.Protocol as SMP +import Simplex.Messaging.Util (bshow, liftIOEither) +import System.Exit (ExitCode (ExitFailure), exitWith) +import System.FilePath (takeDirectory) +import Text.Read (readMaybe) +import UnliftIO.Directory (createDirectoryIfMissing) +import qualified UnliftIO.Exception as E + +-- * SQLite Store implementation + +data SQLiteStore = SQLiteStore + { dbFilePath :: FilePath, + dbConn :: DB.Connection + } + +createSQLiteStore :: MonadUnliftIO m => FilePath -> m SQLiteStore +createSQLiteStore dbFilePath = do + let dbDir = takeDirectory dbFilePath + createDirectoryIfMissing False dbDir + store <- connectSQLiteStore dbFilePath + compileOptions <- liftIO (DB.query_ (dbConn store) "pragma COMPILE_OPTIONS;" :: IO [[T.Text]]) + let threadsafeOption = find (isPrefixOf "THREADSAFE=") (concat compileOptions) + liftIO $ case threadsafeOption of + Just "THREADSAFE=0" -> do + putStrLn "SQLite compiled with not threadsafe code, continue (y/n):" + s <- getLine + when (s /= "y") (exitWith $ ExitFailure 2) + Nothing -> putStrLn "Warning: SQLite THREADSAFE compile option not found" + _ -> return () + liftIO . createSchema $ dbConn store + return store + +connectSQLiteStore :: MonadUnliftIO m => FilePath -> m SQLiteStore +connectSQLiteStore dbFilePath = do + dbConn <- liftIO $ DB.open dbFilePath + liftIO $ + DB.execute_ + dbConn + [sql| + PRAGMA foreign_keys = ON; + PRAGMA journal_mode = WAL; + |] + return SQLiteStore {dbFilePath, dbConn} + +checkDuplicate :: (MonadUnliftIO m, MonadError StoreError m) => IO () -> m () +checkDuplicate action = liftIOEither $ first handleError <$> E.try action + where + handleError :: SQLError -> StoreError + handleError e + | DB.sqlError e == DB.ErrorConstraint = SEConnDuplicate + | otherwise = SEInternal $ bshow e + +withTransaction :: forall a. DB.Connection -> IO a -> IO a +withTransaction db a = loop 100 100_000 + where + loop :: Int -> Int -> IO a + loop t tLim = + DB.withImmediateTransaction db a `E.catch` \(e :: SQLError) -> + if tLim > t && DB.sqlError e == DB.ErrorBusy + then do + threadDelay t + loop (t * 3 `div` 2) (tLim - t) + else E.throwIO e + +instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteStore m where + createRcvConn :: SQLiteStore -> RcvQueue -> m () + createRcvConn SQLiteStore {dbConn} q@RcvQueue {server} = + checkDuplicate $ + withTransaction dbConn $ do + upsertServer_ dbConn server + insertRcvQueue_ dbConn q + insertRcvConnection_ dbConn q + + createSndConn :: SQLiteStore -> SndQueue -> m () + createSndConn SQLiteStore {dbConn} q@SndQueue {server} = + checkDuplicate $ + withTransaction dbConn $ do + upsertServer_ dbConn server + insertSndQueue_ dbConn q + insertSndConnection_ dbConn q + + getConn :: SQLiteStore -> ConnAlias -> m SomeConn + getConn SQLiteStore {dbConn} connAlias = + liftIOEither . withTransaction dbConn $ + getConn_ dbConn connAlias + + getAllConnAliases :: SQLiteStore -> m [ConnAlias] + getAllConnAliases SQLiteStore {dbConn} = + liftIO $ do + r <- DB.query_ dbConn "SELECT conn_alias FROM connections;" :: IO [[ConnAlias]] + return (concat r) + + getRcvConn :: SQLiteStore -> SMPServer -> SMP.RecipientId -> m SomeConn + getRcvConn SQLiteStore {dbConn} SMPServer {host, port} rcvId = + liftIOEither . withTransaction dbConn $ + DB.queryNamed + dbConn + [sql| + SELECT q.conn_alias + FROM rcv_queues q + WHERE q.host = :host AND q.port = :port AND q.rcv_id = :rcv_id; + |] + [":host" := host, ":port" := serializePort_ port, ":rcv_id" := rcvId] + >>= \case + [Only connAlias] -> getConn_ dbConn connAlias + _ -> pure $ Left SEConnNotFound + + deleteConn :: SQLiteStore -> ConnAlias -> m () + deleteConn SQLiteStore {dbConn} connAlias = + liftIO $ + DB.executeNamed + dbConn + "DELETE FROM connections WHERE conn_alias = :conn_alias;" + [":conn_alias" := connAlias] + + upgradeRcvConnToDuplex :: SQLiteStore -> ConnAlias -> SndQueue -> m () + upgradeRcvConnToDuplex SQLiteStore {dbConn} connAlias sq@SndQueue {server} = + liftIOEither . withTransaction dbConn $ + getConn_ dbConn connAlias >>= \case + Right (SomeConn SCRcv (RcvConnection _ _)) -> do + upsertServer_ dbConn server + insertSndQueue_ dbConn sq + updateConnWithSndQueue_ dbConn connAlias sq + pure $ Right () + Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c + _ -> pure $ Left SEConnNotFound + + upgradeSndConnToDuplex :: SQLiteStore -> ConnAlias -> RcvQueue -> m () + upgradeSndConnToDuplex SQLiteStore {dbConn} connAlias rq@RcvQueue {server} = + liftIOEither . withTransaction dbConn $ + getConn_ dbConn connAlias >>= \case + Right (SomeConn SCSnd (SndConnection _ _)) -> do + upsertServer_ dbConn server + insertRcvQueue_ dbConn rq + updateConnWithRcvQueue_ dbConn connAlias rq + pure $ Right () + Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c + _ -> pure $ Left SEConnNotFound + + setRcvQueueStatus :: SQLiteStore -> RcvQueue -> QueueStatus -> m () + setRcvQueueStatus SQLiteStore {dbConn} RcvQueue {rcvId, server = SMPServer {host, port}} status = + -- ? throw error if queue doesn't exist? + liftIO $ + DB.executeNamed + dbConn + [sql| + UPDATE rcv_queues + SET status = :status + WHERE host = :host AND port = :port AND rcv_id = :rcv_id; + |] + [":status" := status, ":host" := host, ":port" := serializePort_ port, ":rcv_id" := rcvId] + + setRcvQueueActive :: SQLiteStore -> RcvQueue -> VerificationKey -> m () + setRcvQueueActive SQLiteStore {dbConn} RcvQueue {rcvId, server = SMPServer {host, port}} verifyKey = + -- ? throw error if queue doesn't exist? + liftIO $ + DB.executeNamed + dbConn + [sql| + UPDATE rcv_queues + SET verify_key = :verify_key, status = :status + WHERE host = :host AND port = :port AND rcv_id = :rcv_id; + |] + [ ":verify_key" := Just verifyKey, + ":status" := Active, + ":host" := host, + ":port" := serializePort_ port, + ":rcv_id" := rcvId + ] + + setSndQueueStatus :: SQLiteStore -> SndQueue -> QueueStatus -> m () + setSndQueueStatus SQLiteStore {dbConn} SndQueue {sndId, server = SMPServer {host, port}} status = + -- ? throw error if queue doesn't exist? + liftIO $ + DB.executeNamed + dbConn + [sql| + UPDATE snd_queues + SET status = :status + WHERE host = :host AND port = :port AND snd_id = :snd_id; + |] + [":status" := status, ":host" := host, ":port" := serializePort_ port, ":snd_id" := sndId] + + updateRcvIds :: SQLiteStore -> RcvQueue -> m (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash) + updateRcvIds SQLiteStore {dbConn} RcvQueue {connAlias} = + liftIO . withTransaction dbConn $ do + (lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash) <- retrieveLastIdsAndHashRcv_ dbConn connAlias + let internalId = InternalId $ unId lastInternalId + 1 + internalRcvId = InternalRcvId $ unRcvId lastInternalRcvId + 1 + updateLastIdsRcv_ dbConn connAlias internalId internalRcvId + pure (internalId, internalRcvId, lastExternalSndId, lastRcvHash) + + createRcvMsg :: SQLiteStore -> RcvQueue -> RcvMsgData -> m () + createRcvMsg SQLiteStore {dbConn} RcvQueue {connAlias} rcvMsgData = + liftIO . withTransaction dbConn $ do + insertRcvMsgBase_ dbConn connAlias rcvMsgData + insertRcvMsgDetails_ dbConn connAlias rcvMsgData + updateHashRcv_ dbConn connAlias rcvMsgData + + updateSndIds :: SQLiteStore -> SndQueue -> m (InternalId, InternalSndId, PrevSndMsgHash) + updateSndIds SQLiteStore {dbConn} SndQueue {connAlias} = + liftIO . withTransaction dbConn $ do + (lastInternalId, lastInternalSndId, prevSndHash) <- retrieveLastIdsAndHashSnd_ dbConn connAlias + let internalId = InternalId $ unId lastInternalId + 1 + internalSndId = InternalSndId $ unSndId lastInternalSndId + 1 + updateLastIdsSnd_ dbConn connAlias internalId internalSndId + pure (internalId, internalSndId, prevSndHash) + + createSndMsg :: SQLiteStore -> SndQueue -> SndMsgData -> m () + createSndMsg SQLiteStore {dbConn} SndQueue {connAlias} sndMsgData = + liftIO . withTransaction dbConn $ do + insertSndMsgBase_ dbConn connAlias sndMsgData + insertSndMsgDetails_ dbConn connAlias sndMsgData + updateHashSnd_ dbConn connAlias sndMsgData + + getMsg :: SQLiteStore -> ConnAlias -> InternalId -> m Msg + getMsg _st _connAlias _id = throwError SENotImplemented + +-- * Auxiliary helpers + +-- ? replace with ToField? - it's easy to forget to use this +serializePort_ :: Maybe ServiceName -> ServiceName +serializePort_ = fromMaybe "_" + +deserializePort_ :: ServiceName -> Maybe ServiceName +deserializePort_ "_" = Nothing +deserializePort_ port = Just port + +instance ToField QueueStatus where toField = toField . show + +instance FromField QueueStatus where fromField = fromFieldToReadable_ + +instance ToField InternalRcvId where toField (InternalRcvId x) = toField x + +instance FromField InternalRcvId where fromField x = InternalRcvId <$> fromField x + +instance ToField InternalSndId where toField (InternalSndId x) = toField x + +instance FromField InternalSndId where fromField x = InternalSndId <$> fromField x + +instance ToField InternalId where toField (InternalId x) = toField x + +instance FromField InternalId where fromField x = InternalId <$> fromField x + +instance ToField RcvMsgStatus where toField = toField . show + +instance ToField SndMsgStatus where toField = toField . show + +instance ToField MsgIntegrity where toField = toField . serializeMsgIntegrity + +instance FromField MsgIntegrity where fromField = blobFieldParser msgIntegrityP + +fromFieldToReadable_ :: forall a. (Read a, E.Typeable a) => Field -> Ok a +fromFieldToReadable_ = \case + f@(Field (SQLText t) _) -> + let str = T.unpack t + in case readMaybe str of + Just x -> Ok x + _ -> returnError ConversionFailed f ("invalid string: " <> str) + f -> returnError ConversionFailed f "expecting SQLText column type" + +{- ORMOLU_DISABLE -} +-- SQLite.Simple only has these up to 10 fields, which is insufficient for some of our queries +instance (FromField a, FromField b, FromField c, FromField d, FromField e, + FromField f, FromField g, FromField h, FromField i, FromField j, + FromField k) => + FromRow (a,b,c,d,e,f,g,h,i,j,k) where + fromRow = (,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field + <*> field <*> field <*> field <*> field <*> field + <*> field +{- ORMOLU_ENABLE -} + +-- * Server upsert helper + +upsertServer_ :: DB.Connection -> SMPServer -> IO () +upsertServer_ dbConn SMPServer {host, port, keyHash} = do + let port_ = serializePort_ port + DB.executeNamed + dbConn + [sql| + INSERT INTO servers (host, port, key_hash) VALUES (:host,:port,:key_hash) + ON CONFLICT (host, port) DO UPDATE SET + host=excluded.host, + port=excluded.port, + key_hash=excluded.key_hash; + |] + [":host" := host, ":port" := port_, ":key_hash" := keyHash] + +-- * createRcvConn helpers + +insertRcvQueue_ :: DB.Connection -> RcvQueue -> IO () +insertRcvQueue_ dbConn RcvQueue {..} = do + let port_ = serializePort_ $ port server + DB.executeNamed + dbConn + [sql| + INSERT INTO rcv_queues + ( host, port, rcv_id, conn_alias, rcv_private_key, snd_id, snd_key, decrypt_key, verify_key, status) + VALUES + (:host,:port,:rcv_id,:conn_alias,:rcv_private_key,:snd_id,:snd_key,:decrypt_key,:verify_key,:status); + |] + [ ":host" := host server, + ":port" := port_, + ":rcv_id" := rcvId, + ":conn_alias" := connAlias, + ":rcv_private_key" := rcvPrivateKey, + ":snd_id" := sndId, + ":snd_key" := sndKey, + ":decrypt_key" := decryptKey, + ":verify_key" := verifyKey, + ":status" := status + ] + +insertRcvConnection_ :: DB.Connection -> RcvQueue -> IO () +insertRcvConnection_ dbConn RcvQueue {server, rcvId, connAlias} = do + let port_ = serializePort_ $ port server + DB.executeNamed + dbConn + [sql| + INSERT INTO connections + ( conn_alias, rcv_host, rcv_port, rcv_id, snd_host, snd_port, snd_id, + last_internal_msg_id, last_internal_rcv_msg_id, last_internal_snd_msg_id, + last_external_snd_msg_id, last_rcv_msg_hash, last_snd_msg_hash) + VALUES + (:conn_alias,:rcv_host,:rcv_port,:rcv_id, NULL, NULL, NULL, + 0, 0, 0, 0, x'', x''); + |] + [":conn_alias" := connAlias, ":rcv_host" := host server, ":rcv_port" := port_, ":rcv_id" := rcvId] + +-- * createSndConn helpers + +insertSndQueue_ :: DB.Connection -> SndQueue -> IO () +insertSndQueue_ dbConn SndQueue {..} = do + let port_ = serializePort_ $ port server + DB.executeNamed + dbConn + [sql| + INSERT INTO snd_queues + ( host, port, snd_id, conn_alias, snd_private_key, encrypt_key, sign_key, status) + VALUES + (:host,:port,:snd_id,:conn_alias,:snd_private_key,:encrypt_key,:sign_key,:status); + |] + [ ":host" := host server, + ":port" := port_, + ":snd_id" := sndId, + ":conn_alias" := connAlias, + ":snd_private_key" := sndPrivateKey, + ":encrypt_key" := encryptKey, + ":sign_key" := signKey, + ":status" := status + ] + +insertSndConnection_ :: DB.Connection -> SndQueue -> IO () +insertSndConnection_ dbConn SndQueue {server, sndId, connAlias} = do + let port_ = serializePort_ $ port server + DB.executeNamed + dbConn + [sql| + INSERT INTO connections + ( conn_alias, rcv_host, rcv_port, rcv_id, snd_host, snd_port, snd_id, + last_internal_msg_id, last_internal_rcv_msg_id, last_internal_snd_msg_id, + last_external_snd_msg_id, last_rcv_msg_hash, last_snd_msg_hash) + VALUES + (:conn_alias, NULL, NULL, NULL,:snd_host,:snd_port,:snd_id, + 0, 0, 0, 0, x'', x''); + |] + [":conn_alias" := connAlias, ":snd_host" := host server, ":snd_port" := port_, ":snd_id" := sndId] + +-- * getConn helpers + +getConn_ :: DB.Connection -> ConnAlias -> IO (Either StoreError SomeConn) +getConn_ dbConn connAlias = do + rQ <- retrieveRcvQueueByConnAlias_ dbConn connAlias + sQ <- retrieveSndQueueByConnAlias_ dbConn connAlias + pure $ case (rQ, sQ) of + (Just rcvQ, Just sndQ) -> Right $ SomeConn SCDuplex (DuplexConnection connAlias rcvQ sndQ) + (Just rcvQ, Nothing) -> Right $ SomeConn SCRcv (RcvConnection connAlias rcvQ) + (Nothing, Just sndQ) -> Right $ SomeConn SCSnd (SndConnection connAlias sndQ) + _ -> Left SEConnNotFound + +retrieveRcvQueueByConnAlias_ :: DB.Connection -> ConnAlias -> IO (Maybe RcvQueue) +retrieveRcvQueueByConnAlias_ dbConn connAlias = do + r <- + DB.queryNamed + dbConn + [sql| + SELECT + s.key_hash, q.host, q.port, q.rcv_id, q.conn_alias, q.rcv_private_key, + q.snd_id, q.snd_key, q.decrypt_key, q.verify_key, q.status + FROM rcv_queues q + INNER JOIN servers s ON q.host = s.host AND q.port = s.port + WHERE q.conn_alias = :conn_alias; + |] + [":conn_alias" := connAlias] + case r of + [(keyHash, host, port, rcvId, cAlias, rcvPrivateKey, sndId, sndKey, decryptKey, verifyKey, status)] -> do + let srv = SMPServer host (deserializePort_ port) keyHash + return . Just $ RcvQueue srv rcvId cAlias rcvPrivateKey sndId sndKey decryptKey verifyKey status + _ -> return Nothing + +retrieveSndQueueByConnAlias_ :: DB.Connection -> ConnAlias -> IO (Maybe SndQueue) +retrieveSndQueueByConnAlias_ dbConn connAlias = do + r <- + DB.queryNamed + dbConn + [sql| + SELECT + s.key_hash, q.host, q.port, q.snd_id, q.conn_alias, + q.snd_private_key, q.encrypt_key, q.sign_key, q.status + FROM snd_queues q + INNER JOIN servers s ON q.host = s.host AND q.port = s.port + WHERE q.conn_alias = :conn_alias; + |] + [":conn_alias" := connAlias] + case r of + [(keyHash, host, port, sndId, cAlias, sndPrivateKey, encryptKey, signKey, status)] -> do + let srv = SMPServer host (deserializePort_ port) keyHash + return . Just $ SndQueue srv sndId cAlias sndPrivateKey encryptKey signKey status + _ -> return Nothing + +-- * upgradeRcvConnToDuplex helpers + +updateConnWithSndQueue_ :: DB.Connection -> ConnAlias -> SndQueue -> IO () +updateConnWithSndQueue_ dbConn connAlias SndQueue {server, sndId} = do + let port_ = serializePort_ $ port server + DB.executeNamed + dbConn + [sql| + UPDATE connections + SET snd_host = :snd_host, snd_port = :snd_port, snd_id = :snd_id + WHERE conn_alias = :conn_alias; + |] + [":snd_host" := host server, ":snd_port" := port_, ":snd_id" := sndId, ":conn_alias" := connAlias] + +-- * upgradeSndConnToDuplex helpers + +updateConnWithRcvQueue_ :: DB.Connection -> ConnAlias -> RcvQueue -> IO () +updateConnWithRcvQueue_ dbConn connAlias RcvQueue {server, rcvId} = do + let port_ = serializePort_ $ port server + DB.executeNamed + dbConn + [sql| + UPDATE connections + SET rcv_host = :rcv_host, rcv_port = :rcv_port, rcv_id = :rcv_id + WHERE conn_alias = :conn_alias; + |] + [":rcv_host" := host server, ":rcv_port" := port_, ":rcv_id" := rcvId, ":conn_alias" := connAlias] + +-- * updateRcvIds helpers + +retrieveLastIdsAndHashRcv_ :: DB.Connection -> ConnAlias -> IO (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash) +retrieveLastIdsAndHashRcv_ dbConn connAlias = do + [(lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash)] <- + DB.queryNamed + dbConn + [sql| + SELECT last_internal_msg_id, last_internal_rcv_msg_id, last_external_snd_msg_id, last_rcv_msg_hash + FROM connections + WHERE conn_alias = :conn_alias; + |] + [":conn_alias" := connAlias] + return (lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash) + +updateLastIdsRcv_ :: DB.Connection -> ConnAlias -> InternalId -> InternalRcvId -> IO () +updateLastIdsRcv_ dbConn connAlias newInternalId newInternalRcvId = + DB.executeNamed + dbConn + [sql| + UPDATE connections + SET last_internal_msg_id = :last_internal_msg_id, + last_internal_rcv_msg_id = :last_internal_rcv_msg_id + WHERE conn_alias = :conn_alias; + |] + [ ":last_internal_msg_id" := newInternalId, + ":last_internal_rcv_msg_id" := newInternalRcvId, + ":conn_alias" := connAlias + ] + +-- * createRcvMsg helpers + +insertRcvMsgBase_ :: DB.Connection -> ConnAlias -> RcvMsgData -> IO () +insertRcvMsgBase_ dbConn connAlias RcvMsgData {..} = do + DB.executeNamed + dbConn + [sql| + INSERT INTO messages + ( conn_alias, internal_id, internal_ts, internal_rcv_id, internal_snd_id, body) + VALUES + (:conn_alias,:internal_id,:internal_ts,:internal_rcv_id, NULL,:body); + |] + [ ":conn_alias" := connAlias, + ":internal_id" := internalId, + ":internal_ts" := internalTs, + ":internal_rcv_id" := internalRcvId, + ":body" := decodeUtf8 msgBody + ] + +insertRcvMsgDetails_ :: DB.Connection -> ConnAlias -> RcvMsgData -> IO () +insertRcvMsgDetails_ dbConn connAlias RcvMsgData {..} = + DB.executeNamed + dbConn + [sql| + INSERT INTO rcv_messages + ( conn_alias, internal_rcv_id, internal_id, external_snd_id, external_snd_ts, + broker_id, broker_ts, rcv_status, ack_brocker_ts, ack_sender_ts, + internal_hash, external_prev_snd_hash, integrity) + VALUES + (:conn_alias,:internal_rcv_id,:internal_id,:external_snd_id,:external_snd_ts, + :broker_id,:broker_ts,:rcv_status, NULL, NULL, + :internal_hash,:external_prev_snd_hash,:integrity); + |] + [ ":conn_alias" := connAlias, + ":internal_rcv_id" := internalRcvId, + ":internal_id" := internalId, + ":external_snd_id" := fst senderMeta, + ":external_snd_ts" := snd senderMeta, + ":broker_id" := fst brokerMeta, + ":broker_ts" := snd brokerMeta, + ":rcv_status" := Received, + ":internal_hash" := internalHash, + ":external_prev_snd_hash" := externalPrevSndHash, + ":integrity" := msgIntegrity + ] + +updateHashRcv_ :: DB.Connection -> ConnAlias -> RcvMsgData -> IO () +updateHashRcv_ dbConn connAlias RcvMsgData {..} = + DB.executeNamed + dbConn + -- last_internal_rcv_msg_id equality check prevents race condition in case next id was reserved + [sql| + UPDATE connections + SET last_external_snd_msg_id = :last_external_snd_msg_id, + last_rcv_msg_hash = :last_rcv_msg_hash + WHERE conn_alias = :conn_alias + AND last_internal_rcv_msg_id = :last_internal_rcv_msg_id; + |] + [ ":last_external_snd_msg_id" := fst senderMeta, + ":last_rcv_msg_hash" := internalHash, + ":conn_alias" := connAlias, + ":last_internal_rcv_msg_id" := internalRcvId + ] + +-- * updateSndIds helpers + +retrieveLastIdsAndHashSnd_ :: DB.Connection -> ConnAlias -> IO (InternalId, InternalSndId, PrevSndMsgHash) +retrieveLastIdsAndHashSnd_ dbConn connAlias = do + [(lastInternalId, lastInternalSndId, lastSndHash)] <- + DB.queryNamed + dbConn + [sql| + SELECT last_internal_msg_id, last_internal_snd_msg_id, last_snd_msg_hash + FROM connections + WHERE conn_alias = :conn_alias; + |] + [":conn_alias" := connAlias] + return (lastInternalId, lastInternalSndId, lastSndHash) + +updateLastIdsSnd_ :: DB.Connection -> ConnAlias -> InternalId -> InternalSndId -> IO () +updateLastIdsSnd_ dbConn connAlias newInternalId newInternalSndId = + DB.executeNamed + dbConn + [sql| + UPDATE connections + SET last_internal_msg_id = :last_internal_msg_id, + last_internal_snd_msg_id = :last_internal_snd_msg_id + WHERE conn_alias = :conn_alias; + |] + [ ":last_internal_msg_id" := newInternalId, + ":last_internal_snd_msg_id" := newInternalSndId, + ":conn_alias" := connAlias + ] + +-- * createSndMsg helpers + +insertSndMsgBase_ :: DB.Connection -> ConnAlias -> SndMsgData -> IO () +insertSndMsgBase_ dbConn connAlias SndMsgData {..} = do + DB.executeNamed + dbConn + [sql| + INSERT INTO messages + ( conn_alias, internal_id, internal_ts, internal_rcv_id, internal_snd_id, body) + VALUES + (:conn_alias,:internal_id,:internal_ts, NULL,:internal_snd_id,:body); + |] + [ ":conn_alias" := connAlias, + ":internal_id" := internalId, + ":internal_ts" := internalTs, + ":internal_snd_id" := internalSndId, + ":body" := decodeUtf8 msgBody + ] + +insertSndMsgDetails_ :: DB.Connection -> ConnAlias -> SndMsgData -> IO () +insertSndMsgDetails_ dbConn connAlias SndMsgData {..} = + DB.executeNamed + dbConn + [sql| + INSERT INTO snd_messages + ( conn_alias, internal_snd_id, internal_id, snd_status, sent_ts, delivered_ts, internal_hash) + VALUES + (:conn_alias,:internal_snd_id,:internal_id,:snd_status, NULL, NULL,:internal_hash); + |] + [ ":conn_alias" := connAlias, + ":internal_snd_id" := internalSndId, + ":internal_id" := internalId, + ":snd_status" := Created, + ":internal_hash" := internalHash + ] + +updateHashSnd_ :: DB.Connection -> ConnAlias -> SndMsgData -> IO () +updateHashSnd_ dbConn connAlias SndMsgData {..} = + DB.executeNamed + dbConn + -- last_internal_snd_msg_id equality check prevents race condition in case next id was reserved + [sql| + UPDATE connections + SET last_snd_msg_hash = :last_snd_msg_hash + WHERE conn_alias = :conn_alias + AND last_internal_snd_msg_id = :last_internal_snd_msg_id; + |] + [ ":last_snd_msg_hash" := internalHash, + ":conn_alias" := connAlias, + ":last_internal_snd_msg_id" := internalSndId + ] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Schema.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Schema.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.SQLite.Schema (createSchema) where + +import Database.SQLite.Simple (Connection, Query, execute_) +import Database.SQLite.Simple.QQ (sql) + +createSchema :: Connection -> IO () +createSchema conn = + mapM_ + (execute_ conn) + [ servers, + rcvQueues, + sndQueues, + connections, + messages, + rcvMessages, + sndMessages + ] + +-- port is either a port number or a service name, see Network.Socket.Info.ServiceName +servers :: Query +servers = + [sql| + CREATE TABLE IF NOT EXISTS servers( + host TEXT NOT NULL, + port TEXT NOT NULL, + key_hash BLOB, + PRIMARY KEY (host, port) + ) WITHOUT ROWID; + |] + +rcvQueues :: Query +rcvQueues = + [sql| + CREATE TABLE IF NOT EXISTS rcv_queues( + host TEXT NOT NULL, + port TEXT NOT NULL, + rcv_id BLOB NOT NULL, + conn_alias BLOB NOT NULL, + rcv_private_key BLOB NOT NULL, + snd_id BLOB, + snd_key BLOB, + decrypt_key BLOB NOT NULL, + verify_key BLOB, + status TEXT NOT NULL, + PRIMARY KEY (host, port, rcv_id), + FOREIGN KEY (host, port) REFERENCES servers (host, port), + FOREIGN KEY (conn_alias) + REFERENCES connections (conn_alias) + ON DELETE CASCADE + DEFERRABLE INITIALLY DEFERRED, + UNIQUE (host, port, snd_id) + ) WITHOUT ROWID; + |] + +sndQueues :: Query +sndQueues = + [sql| + CREATE TABLE IF NOT EXISTS snd_queues( + host TEXT NOT NULL, + port TEXT NOT NULL, + snd_id BLOB NOT NULL, + conn_alias BLOB NOT NULL, + snd_private_key BLOB NOT NULL, + encrypt_key BLOB NOT NULL, + sign_key BLOB NOT NULL, + status TEXT NOT NULL, + PRIMARY KEY (host, port, snd_id), + FOREIGN KEY (host, port) REFERENCES servers (host, port), + FOREIGN KEY (conn_alias) + REFERENCES connections (conn_alias) + ON DELETE CASCADE + DEFERRABLE INITIALLY DEFERRED + ) WITHOUT ROWID; + |] + +connections :: Query +connections = + [sql| + CREATE TABLE IF NOT EXISTS connections( + conn_alias BLOB NOT NULL, + rcv_host TEXT, + rcv_port TEXT, + rcv_id BLOB, + snd_host TEXT, + snd_port TEXT, + snd_id BLOB, + last_internal_msg_id INTEGER NOT NULL, + last_internal_rcv_msg_id INTEGER NOT NULL, + last_internal_snd_msg_id INTEGER NOT NULL, + last_external_snd_msg_id INTEGER NOT NULL, + last_rcv_msg_hash BLOB NOT NULL, + last_snd_msg_hash BLOB NOT NULL, + PRIMARY KEY (conn_alias), + FOREIGN KEY (rcv_host, rcv_port, rcv_id) REFERENCES rcv_queues (host, port, rcv_id), + FOREIGN KEY (snd_host, snd_port, snd_id) REFERENCES snd_queues (host, port, snd_id) + ) WITHOUT ROWID; + |] + +messages :: Query +messages = + [sql| + CREATE TABLE IF NOT EXISTS messages( + conn_alias BLOB NOT NULL, + internal_id INTEGER NOT NULL, + internal_ts TEXT NOT NULL, + internal_rcv_id INTEGER, + internal_snd_id INTEGER, + body TEXT NOT NULL, + PRIMARY KEY (conn_alias, internal_id), + FOREIGN KEY (conn_alias) + REFERENCES connections (conn_alias) + ON DELETE CASCADE, + FOREIGN KEY (conn_alias, internal_rcv_id) + REFERENCES rcv_messages (conn_alias, internal_rcv_id) + ON DELETE CASCADE + DEFERRABLE INITIALLY DEFERRED, + FOREIGN KEY (conn_alias, internal_snd_id) + REFERENCES snd_messages (conn_alias, internal_snd_id) + ON DELETE CASCADE + DEFERRABLE INITIALLY DEFERRED + ) WITHOUT ROWID; + |] + +rcvMessages :: Query +rcvMessages = + [sql| + CREATE TABLE IF NOT EXISTS rcv_messages( + conn_alias BLOB NOT NULL, + internal_rcv_id INTEGER NOT NULL, + internal_id INTEGER NOT NULL, + external_snd_id INTEGER NOT NULL, + external_snd_ts TEXT NOT NULL, + broker_id BLOB NOT NULL, + broker_ts TEXT NOT NULL, + rcv_status TEXT NOT NULL, + ack_brocker_ts TEXT, + ack_sender_ts TEXT, + internal_hash BLOB NOT NULL, + external_prev_snd_hash BLOB NOT NULL, + integrity BLOB NOT NULL, + PRIMARY KEY (conn_alias, internal_rcv_id), + FOREIGN KEY (conn_alias, internal_id) + REFERENCES messages (conn_alias, internal_id) + ON DELETE CASCADE + ) WITHOUT ROWID; + |] + +sndMessages :: Query +sndMessages = + [sql| + CREATE TABLE IF NOT EXISTS snd_messages( + conn_alias BLOB NOT NULL, + internal_snd_id INTEGER NOT NULL, + internal_id INTEGER NOT NULL, + snd_status TEXT NOT NULL, + sent_ts TEXT, + delivered_ts TEXT, + internal_hash BLOB NOT NULL, + PRIMARY KEY (conn_alias, internal_snd_id), + FOREIGN KEY (conn_alias, internal_id) + REFERENCES messages (conn_alias, internal_id) + ON DELETE CASCADE + ) WITHOUT ROWID; + |] diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs new file mode 100644 --- /dev/null +++ b/src/Simplex/Messaging/Client.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Simplex.Messaging.Client +-- Copyright : (c) simplex.chat +-- License : AGPL-3 +-- +-- Maintainer : chat@simplex.chat +-- Stability : experimental +-- Portability : non-portable +-- +-- This module provides a functional client API for SMP protocol. +-- +-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md +module Simplex.Messaging.Client + ( -- * Connect (disconnect) client to (from) SMP server + SMPClient (blockSize), + getSMPClient, + closeSMPClient, + + -- * SMP protocol command functions + createSMPQueue, + subscribeSMPQueue, + secureSMPQueue, + sendSMPMessage, + ackSMPMessage, + suspendSMPQueue, + deleteSMPQueue, + sendSMPCommand, + + -- * Supporting types and client configuration + SMPClientError (..), + SMPClientConfig (..), + smpDefaultConfig, + SMPServerTransmission, + ) +where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Exception +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import Data.ByteString.Char8 (ByteString) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe +import Network.Socket (ServiceName) +import Numeric.Natural +import Simplex.Messaging.Agent.Protocol (SMPServer (..)) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Protocol +import Simplex.Messaging.Transport (THandle (..), TransportError, clientHandshake, runTCPClient) +import Simplex.Messaging.Util (bshow, liftError, raceAny_) +import System.IO +import System.Timeout + +-- | 'SMPClient' is a handle used to send commands to a specific SMP server. +-- +-- The only exported selector is blockSize that is negotiated +-- with the server during the TCP transport handshake. +-- +-- Use 'getSMPClient' to connect to an SMP server and create a client handle. +data SMPClient = SMPClient + { action :: Async (), + connected :: TVar Bool, + smpServer :: SMPServer, + tcpTimeout :: Int, + clientCorrId :: TVar Natural, + sentCommands :: TVar (Map CorrId Request), + sndQ :: TBQueue SignedRawTransmission, + rcvQ :: TBQueue SignedTransmissionOrError, + msgQ :: TBQueue SMPServerTransmission, + blockSize :: Int + } + +-- | Type synonym for transmission from some SPM server queue. +type SMPServerTransmission = (SMPServer, RecipientId, Command 'Broker) + +-- | SMP client configuration. +data SMPClientConfig = SMPClientConfig + { -- | size of TBQueue to use for server commands and responses + qSize :: Natural, + -- | default SMP server port if port is not specified in SMPServer + defaultPort :: ServiceName, + -- | timeout of TCP commands (microseconds) + tcpTimeout :: Int, + -- | period for SMP ping commands (microseconds) + smpPing :: Int, + -- | estimated maximum size of SMP command excluding message body, + -- determines the maximum allowed message size + smpCommandSize :: Int + } + +-- | Default SMP client configuration. +smpDefaultConfig :: SMPClientConfig +smpDefaultConfig = + SMPClientConfig + { qSize = 16, + defaultPort = "5223", + tcpTimeout = 4_000_000, + smpPing = 30_000_000, + smpCommandSize = 256 + } + +data Request = Request + { queueId :: QueueId, + responseVar :: TMVar Response + } + +type Response = Either SMPClientError Cmd + +-- | Connects to 'SMPServer' using passed client configuration +-- and queue for messages and notifications. +-- +-- A single queue can be used for multiple 'SMPClient' instances, +-- as 'SMPServerTransmission' includes server information. +getSMPClient :: SMPServer -> SMPClientConfig -> TBQueue SMPServerTransmission -> IO () -> IO (Either SMPClientError SMPClient) +getSMPClient + smpServer@SMPServer {host, port, keyHash} + SMPClientConfig {qSize, defaultPort, tcpTimeout, smpPing} + msgQ + disconnected = do + c <- atomically mkSMPClient + thVar <- newEmptyTMVarIO + action <- + async $ + runTCPClient host (fromMaybe defaultPort port) (client c thVar) + `finally` atomically (putTMVar thVar $ Left SMPNetworkError) + tHandle <- tcpTimeout `timeout` atomically (takeTMVar thVar) + pure $ case tHandle of + Just (Right THandle {blockSize}) -> Right c {action, blockSize} + Just (Left e) -> Left e + Nothing -> Left SMPNetworkError + where + mkSMPClient :: STM SMPClient + mkSMPClient = do + connected <- newTVar False + clientCorrId <- newTVar 0 + sentCommands <- newTVar M.empty + sndQ <- newTBQueue qSize + rcvQ <- newTBQueue qSize + return + SMPClient + { action = undefined, + blockSize = undefined, + connected, + smpServer, + tcpTimeout, + clientCorrId, + sentCommands, + sndQ, + rcvQ, + msgQ + } + + client :: SMPClient -> TMVar (Either SMPClientError THandle) -> Handle -> IO () + client c thVar h = + runExceptT (clientHandshake h keyHash) >>= \case + Right th -> clientTransport c thVar th + Left e -> atomically . putTMVar thVar . Left $ SMPTransportError e + + clientTransport :: SMPClient -> TMVar (Either SMPClientError THandle) -> THandle -> IO () + clientTransport c thVar th = do + atomically $ do + writeTVar (connected c) True + putTMVar thVar $ Right th + raceAny_ [send c th, process c, receive c th, ping c] + `finally` disconnected + + send :: SMPClient -> THandle -> IO () + send SMPClient {sndQ} h = forever $ atomically (readTBQueue sndQ) >>= tPut h + + receive :: SMPClient -> THandle -> IO () + receive SMPClient {rcvQ} h = forever $ tGet fromServer h >>= atomically . writeTBQueue rcvQ + + ping :: SMPClient -> IO () + ping c = forever $ do + threadDelay smpPing + runExceptT $ sendSMPCommand c Nothing "" (Cmd SSender PING) + + process :: SMPClient -> IO () + process SMPClient {rcvQ, sentCommands} = forever $ do + (_, (corrId, qId, respOrErr)) <- atomically $ readTBQueue rcvQ + cs <- readTVarIO sentCommands + case M.lookup corrId cs of + Nothing -> do + case respOrErr of + Right (Cmd SBroker cmd) -> atomically $ writeTBQueue msgQ (smpServer, qId, cmd) + -- TODO send everything else to errQ and log in agent + _ -> return () + Just Request {queueId, responseVar} -> atomically $ do + modifyTVar sentCommands $ M.delete corrId + putTMVar responseVar $ + if queueId == qId + then case respOrErr of + Left e -> Left $ SMPResponseError e + Right (Cmd _ (ERR e)) -> Left $ SMPServerError e + Right r -> Right r + else Left SMPUnexpectedResponse + +-- | Disconnects SMP client from the server and terminates client threads. +closeSMPClient :: SMPClient -> IO () +closeSMPClient = uninterruptibleCancel . action + +-- | SMP client error type. +data SMPClientError + = -- | Correctly parsed SMP server ERR response. + -- This error is forwarded to the agent client as `ERR SMP err`. + SMPServerError ErrorType + | -- | Invalid server response that failed to parse. + -- Forwarded to the agent client as `ERR BROKER RESPONSE`. + SMPResponseError ErrorType + | -- | Different response from what is expected to a certain SMP command, + -- e.g. server should respond `IDS` or `ERR` to `NEW` command, + -- other responses would result in this error. + -- Forwarded to the agent client as `ERR BROKER UNEXPECTED`. + SMPUnexpectedResponse + | -- | Used for TCP connection and command response timeouts. + -- Forwarded to the agent client as `ERR BROKER TIMEOUT`. + SMPResponseTimeout + | -- | Failure to establish TCP connection. + -- Forwarded to the agent client as `ERR BROKER NETWORK`. + SMPNetworkError + | -- | TCP transport handshake or some other transport error. + -- Forwarded to the agent client as `ERR BROKER TRANSPORT e`. + SMPTransportError TransportError + | -- | Error when cryptographically "signing" the command. + SMPSignatureError C.CryptoError + deriving (Eq, Show, Exception) + +-- | Create a new SMP queue. +-- +-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command +createSMPQueue :: + SMPClient -> + RecipientPrivateKey -> + RecipientPublicKey -> + ExceptT SMPClientError IO (RecipientId, SenderId) +createSMPQueue c rpKey rKey = + -- TODO add signing this request too - requires changes in the server + sendSMPCommand c (Just rpKey) "" (Cmd SRecipient $ NEW rKey) >>= \case + Cmd _ (IDS rId sId) -> return (rId, sId) + _ -> throwE SMPUnexpectedResponse + +-- | Subscribe to the SMP queue. +-- +-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue +subscribeSMPQueue :: SMPClient -> RecipientPrivateKey -> RecipientId -> ExceptT SMPClientError IO () +subscribeSMPQueue c@SMPClient {smpServer, msgQ} rpKey rId = + sendSMPCommand c (Just rpKey) rId (Cmd SRecipient SUB) >>= \case + Cmd _ OK -> return () + Cmd _ cmd@MSG {} -> + lift . atomically $ writeTBQueue msgQ (smpServer, rId, cmd) + _ -> throwE SMPUnexpectedResponse + +-- | Secure the SMP queue by adding a sender public key. +-- +-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#secure-queue-command +secureSMPQueue :: SMPClient -> RecipientPrivateKey -> RecipientId -> SenderPublicKey -> ExceptT SMPClientError IO () +secureSMPQueue c rpKey rId senderKey = okSMPCommand (Cmd SRecipient $ KEY senderKey) c rpKey rId + +-- | Send SMP message. +-- +-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message +sendSMPMessage :: SMPClient -> Maybe SenderPrivateKey -> SenderId -> MsgBody -> ExceptT SMPClientError IO () +sendSMPMessage c spKey sId msg = + sendSMPCommand c spKey sId (Cmd SSender $ SEND msg) >>= \case + Cmd _ OK -> return () + _ -> throwE SMPUnexpectedResponse + +-- | Acknowledge message delivery (server deletes the message). +-- +-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery +ackSMPMessage :: SMPClient -> RecipientPrivateKey -> QueueId -> ExceptT SMPClientError IO () +ackSMPMessage c@SMPClient {smpServer, msgQ} rpKey rId = + sendSMPCommand c (Just rpKey) rId (Cmd SRecipient ACK) >>= \case + Cmd _ OK -> return () + Cmd _ cmd@MSG {} -> + lift . atomically $ writeTBQueue msgQ (smpServer, rId, cmd) + _ -> throwE SMPUnexpectedResponse + +-- | Irreversibly suspend SMP queue. +-- The existing messages from the queue will still be delivered. +-- +-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#suspend-queue +suspendSMPQueue :: SMPClient -> RecipientPrivateKey -> QueueId -> ExceptT SMPClientError IO () +suspendSMPQueue = okSMPCommand $ Cmd SRecipient OFF + +-- | Irreversibly delete SMP queue and all messages in it. +-- +-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#delete-queue +deleteSMPQueue :: SMPClient -> RecipientPrivateKey -> QueueId -> ExceptT SMPClientError IO () +deleteSMPQueue = okSMPCommand $ Cmd SRecipient DEL + +okSMPCommand :: Cmd -> SMPClient -> C.SafePrivateKey -> QueueId -> ExceptT SMPClientError IO () +okSMPCommand cmd c pKey qId = + sendSMPCommand c (Just pKey) qId cmd >>= \case + Cmd _ OK -> return () + _ -> throwE SMPUnexpectedResponse + +-- | Send any SMP command ('Cmd' type). +sendSMPCommand :: SMPClient -> Maybe C.SafePrivateKey -> QueueId -> Cmd -> ExceptT SMPClientError IO Cmd +sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId, tcpTimeout} pKey qId cmd = do + corrId <- lift_ getNextCorrId + t <- signTransmission $ serializeTransmission (corrId, qId, cmd) + ExceptT $ sendRecv corrId t + where + lift_ :: STM a -> ExceptT SMPClientError IO a + lift_ action = ExceptT $ Right <$> atomically action + + getNextCorrId :: STM CorrId + getNextCorrId = do + i <- stateTVar clientCorrId $ \i -> (i, i + 1) + pure . CorrId $ bshow i + + signTransmission :: ByteString -> ExceptT SMPClientError IO SignedRawTransmission + signTransmission t = case pKey of + Nothing -> return ("", t) + Just pk -> do + sig <- liftError SMPSignatureError $ C.sign pk t + return (sig, t) + + -- two separate "atomically" needed to avoid blocking + sendRecv :: CorrId -> SignedRawTransmission -> IO Response + sendRecv corrId t = atomically (send corrId t) >>= withTimeout . atomically . takeTMVar + where + withTimeout a = fromMaybe (Left SMPResponseTimeout) <$> timeout tcpTimeout a + + send :: CorrId -> SignedRawTransmission -> STM (TMVar Response) + send corrId t = do + r <- newEmptyTMVar + modifyTVar sentCommands . M.insert corrId $ Request qId r + writeTBQueue sndQ t + return r diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs new file mode 100644 --- /dev/null +++ b/src/Simplex/Messaging/Crypto.hs @@ -0,0 +1,483 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module : Simplex.Messaging.Crypto +-- Copyright : (c) simplex.chat +-- License : AGPL-3 +-- +-- Maintainer : chat@simplex.chat +-- Stability : experimental +-- Portability : non-portable +-- +-- This module provides cryptography implementation for SMP protocols based on +-- . +module Simplex.Messaging.Crypto + ( -- * RSA keys + PrivateKey (rsaPrivateKey), + SafePrivateKey, -- constructor is not exported + FullPrivateKey (..), + PublicKey (..), + SafeKeyPair, + FullKeyPair, + KeyHash (..), + generateKeyPair, + publicKey, + publicKeySize, + validKeySize, + safePrivateKey, + + -- * E2E hybrid encryption scheme + encrypt, + decrypt, + + -- * RSA OAEP encryption + encryptOAEP, + decryptOAEP, + + -- * RSA PSS signing + Signature (..), + sign, + verify, + + -- * AES256 AEAD-GCM scheme + Key (..), + IV (..), + encryptAES, + decryptAES, + authTagSize, + authTagToBS, + bsToAuthTag, + randomAesKey, + randomIV, + aesKeyP, + ivP, + + -- * Encoding of RSA keys + serializePrivKey, + serializePubKey, + encodePubKey, + publicKeyHash, + privKeyP, + pubKeyP, + binaryPubKeyP, + + -- * SHA256 hash + sha256Hash, + + -- * Cryptography error type + CryptoError (..), + ) +where + +import Control.Exception (Exception) +import Control.Monad.Except +import Control.Monad.Trans.Except +import Crypto.Cipher.AES (AES256) +import qualified Crypto.Cipher.Types as AES +import qualified Crypto.Error as CE +import Crypto.Hash (Digest, SHA256 (..), hash) +import Crypto.Number.Generate (generateMax) +import Crypto.Number.Prime (findPrimeFrom) +import qualified Crypto.PubKey.RSA as R +import qualified Crypto.PubKey.RSA.OAEP as OAEP +import qualified Crypto.PubKey.RSA.PSS as PSS +import Crypto.Random (getRandomBytes) +import Data.ASN1.BinaryEncoding +import Data.ASN1.Encoding +import Data.ASN1.Types +import Data.Attoparsec.ByteString.Char8 (Parser) +import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.Bifunctor (bimap, first) +import qualified Data.ByteArray as BA +import Data.ByteString.Base64 (decode, encode) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.ByteString.Internal (c2w, w2c) +import Data.ByteString.Lazy (fromStrict, toStrict) +import Data.String +import Data.X509 +import Database.SQLite.Simple.FromField (FromField (..)) +import Database.SQLite.Simple.ToField (ToField (..)) +import Network.Transport.Internal (decodeWord32, encodeWord32) +import Simplex.Messaging.Parsers (base64P, blobFieldParser, parseAll, parseString) +import Simplex.Messaging.Util (liftEitherError, (<$?>)) + +-- | A newtype of 'Crypto.PubKey.RSA.PublicKey'. +newtype PublicKey = PublicKey {rsaPublicKey :: R.PublicKey} deriving (Eq, Show) + +-- | A newtype of 'Crypto.PubKey.RSA.PrivateKey', with PublicKey removed. +-- +-- It is not possible to recover PublicKey from SafePrivateKey. +-- The constructor of this type is not exported. +newtype SafePrivateKey = SafePrivateKey {unPrivateKey :: R.PrivateKey} deriving (Eq, Show) + +-- | A newtype of 'Crypto.PubKey.RSA.PrivateKey' (with PublicKey inside). +newtype FullPrivateKey = FullPrivateKey {unPrivateKey :: R.PrivateKey} deriving (Eq, Show) + +-- | Type-class used for both private key types: SafePrivateKey and FullPrivateKey. +class PrivateKey k where + -- unwraps 'Crypto.PubKey.RSA.PrivateKey' + rsaPrivateKey :: k -> R.PrivateKey + + -- equivalent to data type constructor, not exported + _privateKey :: R.PrivateKey -> k + + -- smart constructor removing public key from SafePrivateKey but keeping it in FullPrivateKey + mkPrivateKey :: R.PrivateKey -> k + +instance PrivateKey SafePrivateKey where + rsaPrivateKey = unPrivateKey + _privateKey = SafePrivateKey + mkPrivateKey R.PrivateKey {private_pub = k, private_d} = + safePrivateKey (R.public_size k, R.public_n k, private_d) + +instance PrivateKey FullPrivateKey where + rsaPrivateKey = unPrivateKey + _privateKey = FullPrivateKey + mkPrivateKey = FullPrivateKey + +instance IsString FullPrivateKey where + fromString = parseString (decode >=> decodePrivKey) + +instance IsString PublicKey where + fromString = parseString (decode >=> decodePubKey) + +instance ToField SafePrivateKey where toField = toField . encodePrivKey + +instance ToField PublicKey where toField = toField . encodePubKey + +instance FromField SafePrivateKey where fromField = blobFieldParser binaryPrivKeyP + +instance FromField PublicKey where fromField = blobFieldParser binaryPubKeyP + +-- | Tuple of RSA 'PublicKey' and 'PrivateKey'. +type KeyPair k = (PublicKey, k) + +-- | Tuple of RSA 'PublicKey' and 'SafePrivateKey'. +type SafeKeyPair = (PublicKey, SafePrivateKey) + +-- | Tuple of RSA 'PublicKey' and 'FullPrivateKey'. +type FullKeyPair = (PublicKey, FullPrivateKey) + +-- | RSA signature newtype. +newtype Signature = Signature {unSignature :: ByteString} deriving (Eq, Show) + +instance IsString Signature where + fromString = Signature . fromString + +-- | Various cryptographic or related errors. +data CryptoError + = -- | RSA OAEP encryption error + RSAEncryptError R.Error + | -- | RSA OAEP decryption error + RSADecryptError R.Error + | -- | RSA PSS signature error + RSASignError R.Error + | -- | AES initialization error + AESCipherError CE.CryptoError + | -- | IV generation error + CryptoIVError + | -- | AES decryption error + AESDecryptError + | -- | message does not fit in SMP block + CryptoLargeMsgError + | -- | failure parsing RSA-encrypted message header + CryptoHeaderError String + deriving (Eq, Show, Exception) + +pubExpRange :: Integer +pubExpRange = 2 ^ (1024 :: Int) + +aesKeySize :: Int +aesKeySize = 256 `div` 8 + +authTagSize :: Int +authTagSize = 128 `div` 8 + +-- | Generate RSA key pair with either SafePrivateKey or FullPrivateKey. +generateKeyPair :: PrivateKey k => Int -> IO (KeyPair k) +generateKeyPair size = loop + where + publicExponent = findPrimeFrom . (+ 3) <$> generateMax pubExpRange + loop = do + (k, pk) <- R.generate size =<< publicExponent + let n = R.public_n k + d = R.private_d pk + if d * d < n + then loop + else pure (PublicKey k, mkPrivateKey pk) + +privateKeySize :: PrivateKey k => k -> Int +privateKeySize = R.public_size . R.private_pub . rsaPrivateKey + +publicKey :: FullPrivateKey -> PublicKey +publicKey = PublicKey . R.private_pub . rsaPrivateKey + +publicKeySize :: PublicKey -> Int +publicKeySize = R.public_size . rsaPublicKey + +validKeySize :: Int -> Bool +validKeySize = \case + 128 -> True + 256 -> True + 512 -> True + _ -> False + +data Header = Header + { aesKey :: Key, + ivBytes :: IV, + authTag :: AES.AuthTag, + msgSize :: Int + } + +-- | AES key newtype. +newtype Key = Key {unKey :: ByteString} + +-- | IV bytes newtype. +newtype IV = IV {unIV :: ByteString} + +-- | Key hash newtype. +newtype KeyHash = KeyHash {unKeyHash :: ByteString} deriving (Eq, Ord, Show) + +instance IsString KeyHash where + fromString = parseString . parseAll $ KeyHash <$> base64P + +instance ToField KeyHash where toField = toField . encode . unKeyHash + +instance FromField KeyHash where fromField = blobFieldParser $ KeyHash <$> base64P + +-- | Digest (hash) of binary X509 encoding of RSA public key. +publicKeyHash :: PublicKey -> KeyHash +publicKeyHash = KeyHash . sha256Hash . encodePubKey + +-- | SHA256 digest. +sha256Hash :: ByteString -> ByteString +sha256Hash = BA.convert . (hash :: ByteString -> Digest SHA256) + +serializeHeader :: Header -> ByteString +serializeHeader Header {aesKey, ivBytes, authTag, msgSize} = + unKey aesKey <> unIV ivBytes <> authTagToBS authTag <> (encodeWord32 . fromIntegral) msgSize + +headerP :: Parser Header +headerP = do + aesKey <- aesKeyP + ivBytes <- ivP + authTag <- bsToAuthTag <$> A.take authTagSize + msgSize <- fromIntegral . decodeWord32 <$> A.take 4 + return Header {aesKey, ivBytes, authTag, msgSize} + +-- | AES256 key parser. +aesKeyP :: Parser Key +aesKeyP = Key <$> A.take aesKeySize + +-- | IV bytes parser. +ivP :: Parser IV +ivP = IV <$> A.take (ivSize @AES256) + +parseHeader :: ByteString -> Either CryptoError Header +parseHeader = first CryptoHeaderError . parseAll headerP + +-- * E2E hybrid encryption scheme + +-- | E2E encrypt SMP agent messages. +-- +-- https://github.com/simplex-chat/simplexmq/blob/master/rfcs/2021-01-26-crypto.md#e2e-encryption +encrypt :: PublicKey -> Int -> ByteString -> ExceptT CryptoError IO ByteString +encrypt k paddedSize msg = do + aesKey <- liftIO randomAesKey + ivBytes <- liftIO randomIV + (authTag, msg') <- encryptAES aesKey ivBytes paddedSize msg + let header = Header {aesKey, ivBytes, authTag, msgSize = B.length msg} + encHeader <- encryptOAEP k $ serializeHeader header + return $ encHeader <> msg' + +-- | E2E decrypt SMP agent messages. +-- +-- https://github.com/simplex-chat/simplexmq/blob/master/rfcs/2021-01-26-crypto.md#e2e-encryption +decrypt :: PrivateKey k => k -> ByteString -> ExceptT CryptoError IO ByteString +decrypt pk msg'' = do + let (encHeader, msg') = B.splitAt (privateKeySize pk) msg'' + header <- decryptOAEP pk encHeader + Header {aesKey, ivBytes, authTag, msgSize} <- except $ parseHeader header + msg <- decryptAES aesKey ivBytes msg' authTag + return $ B.take msgSize msg + +-- | AEAD-GCM encryption. +-- +-- Used as part of hybrid E2E encryption scheme and for SMP transport blocks encryption. +encryptAES :: Key -> IV -> Int -> ByteString -> ExceptT CryptoError IO (AES.AuthTag, ByteString) +encryptAES aesKey ivBytes paddedSize msg = do + aead <- initAEAD @AES256 aesKey ivBytes + msg' <- paddedMsg + return $ AES.aeadSimpleEncrypt aead B.empty msg' authTagSize + where + len = B.length msg + paddedMsg + | len >= paddedSize = throwE CryptoLargeMsgError + | otherwise = return (msg <> B.replicate (paddedSize - len) '#') + +-- | AEAD-GCM decryption. +-- +-- Used as part of hybrid E2E encryption scheme and for SMP transport blocks decryption. +decryptAES :: Key -> IV -> ByteString -> AES.AuthTag -> ExceptT CryptoError IO ByteString +decryptAES aesKey ivBytes msg authTag = do + aead <- initAEAD @AES256 aesKey ivBytes + maybeError AESDecryptError $ AES.aeadSimpleDecrypt aead B.empty msg authTag + +initAEAD :: forall c. AES.BlockCipher c => Key -> IV -> ExceptT CryptoError IO (AES.AEAD c) +initAEAD (Key aesKey) (IV ivBytes) = do + iv <- makeIV @c ivBytes + cryptoFailable $ do + cipher <- AES.cipherInit aesKey + AES.aeadInit AES.AEAD_GCM cipher iv + +-- | Random AES256 key. +randomAesKey :: IO Key +randomAesKey = Key <$> getRandomBytes aesKeySize + +-- | Random IV bytes for AES256 encryption. +randomIV :: IO IV +randomIV = IV <$> getRandomBytes (ivSize @AES256) + +ivSize :: forall c. AES.BlockCipher c => Int +ivSize = AES.blockSize (undefined :: c) + +makeIV :: AES.BlockCipher c => ByteString -> ExceptT CryptoError IO (AES.IV c) +makeIV bs = maybeError CryptoIVError $ AES.makeIV bs + +maybeError :: CryptoError -> Maybe a -> ExceptT CryptoError IO a +maybeError e = maybe (throwE e) return + +-- | Convert AEAD 'AuthTag' to ByteString. +authTagToBS :: AES.AuthTag -> ByteString +authTagToBS = B.pack . map w2c . BA.unpack . AES.unAuthTag + +-- | Convert ByteString to AEAD 'AuthTag'. +bsToAuthTag :: ByteString -> AES.AuthTag +bsToAuthTag = AES.AuthTag . BA.pack . map c2w . B.unpack + +cryptoFailable :: CE.CryptoFailable a -> ExceptT CryptoError IO a +cryptoFailable = liftEither . first AESCipherError . CE.eitherCryptoError + +oaepParams :: OAEP.OAEPParams SHA256 ByteString ByteString +oaepParams = OAEP.defaultOAEPParams SHA256 + +-- | RSA OAEP encryption. +-- +-- Used as part of hybrid E2E encryption scheme and for SMP transport handshake. +encryptOAEP :: PublicKey -> ByteString -> ExceptT CryptoError IO ByteString +encryptOAEP (PublicKey k) aesKey = + liftEitherError RSAEncryptError $ + OAEP.encrypt oaepParams k aesKey + +-- | RSA OAEP decryption. +-- +-- Used as part of hybrid E2E encryption scheme and for SMP transport handshake. +decryptOAEP :: PrivateKey k => k -> ByteString -> ExceptT CryptoError IO ByteString +decryptOAEP pk encKey = + liftEitherError RSADecryptError $ + OAEP.decryptSafer oaepParams (rsaPrivateKey pk) encKey + +pssParams :: PSS.PSSParams SHA256 ByteString ByteString +pssParams = PSS.defaultPSSParams SHA256 + +-- | RSA PSS message signing. +-- +-- Used by SMP clients to sign SMP commands and by SMP agents to sign messages. +sign :: PrivateKey k => k -> ByteString -> ExceptT CryptoError IO Signature +sign pk msg = ExceptT $ bimap RSASignError Signature <$> PSS.signSafer pssParams (rsaPrivateKey pk) msg + +-- | RSA PSS signature verification. +-- +-- Used by SMP servers to authorize SMP commands and by SMP agents to verify messages. +verify :: PublicKey -> Signature -> ByteString -> Bool +verify (PublicKey k) (Signature sig) msg = PSS.verify pssParams k msg sig + +-- | Base-64 X509 encoding of RSA public key. +-- +-- Used as part of SMP queue information (out-of-band message). +serializePubKey :: PublicKey -> ByteString +serializePubKey = ("rsa:" <>) . encode . encodePubKey + +-- | Base-64 PKCS8 encoding of PSA private key. +-- +-- Not used as part of SMP protocols. +serializePrivKey :: PrivateKey k => k -> ByteString +serializePrivKey = ("rsa:" <>) . encode . encodePrivKey + +-- Base-64 X509 RSA public key parser. +pubKeyP :: Parser PublicKey +pubKeyP = decodePubKey <$?> ("rsa:" *> base64P) + +-- Binary X509 RSA public key parser. +binaryPubKeyP :: Parser PublicKey +binaryPubKeyP = decodePubKey <$?> A.takeByteString + +-- Base-64 PKCS8 RSA private key parser. +privKeyP :: PrivateKey k => Parser k +privKeyP = decodePrivKey <$?> ("rsa:" *> base64P) + +-- Binary PKCS8 RSA private key parser. +binaryPrivKeyP :: PrivateKey k => Parser k +binaryPrivKeyP = decodePrivKey <$?> A.takeByteString + +-- | Construct 'SafePrivateKey' from three numbers - used internally and in the tests. +safePrivateKey :: (Int, Integer, Integer) -> SafePrivateKey +safePrivateKey = SafePrivateKey . safeRsaPrivateKey + +safeRsaPrivateKey :: (Int, Integer, Integer) -> R.PrivateKey +safeRsaPrivateKey (size, n, d) = + R.PrivateKey + { private_pub = + R.PublicKey + { public_size = size, + public_n = n, + public_e = 0 + }, + private_d = d, + private_p = 0, + private_q = 0, + private_dP = 0, + private_dQ = 0, + private_qinv = 0 + } + +-- Binary X509 encoding of 'PublicKey'. +encodePubKey :: PublicKey -> ByteString +encodePubKey = encodeKey . PubKeyRSA . rsaPublicKey + +-- Binary PKCS8 encoding of 'PrivateKey'. +encodePrivKey :: PrivateKey k => k -> ByteString +encodePrivKey = encodeKey . PrivKeyRSA . rsaPrivateKey + +encodeKey :: ASN1Object a => a -> ByteString +encodeKey k = toStrict . encodeASN1 DER $ toASN1 k [] + +-- Decoding of binary X509 'PublicKey'. +decodePubKey :: ByteString -> Either String PublicKey +decodePubKey = + decodeKey >=> \case + (PubKeyRSA k, []) -> Right $ PublicKey k + r -> keyError r + +-- Decoding of binary PKCS8 'PrivateKey'. +decodePrivKey :: PrivateKey k => ByteString -> Either String k +decodePrivKey = + decodeKey >=> \case + (PrivKeyRSA pk, []) -> Right $ mkPrivateKey pk + r -> keyError r + +decodeKey :: ASN1Object a => ByteString -> Either String (a, [ASN1]) +decodeKey = fromASN1 <=< first show . decodeASN1 DER . fromStrict + +keyError :: (a, [ASN1]) -> Either String b +keyError = \case + (_, []) -> Left "not RSA key" + _ -> Left "more than one key" diff --git a/src/Simplex/Messaging/Parsers.hs b/src/Simplex/Messaging/Parsers.hs new file mode 100644 --- /dev/null +++ b/src/Simplex/Messaging/Parsers.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Simplex.Messaging.Parsers where + +import Data.Attoparsec.ByteString.Char8 (Parser) +import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.Bifunctor (first) +import Data.ByteString.Base64 +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Char (isAlphaNum) +import Data.Time.Clock (UTCTime) +import Data.Time.ISO8601 (parseISO8601) +import Data.Typeable (Typeable) +import Database.SQLite.Simple (ResultError (..), SQLData (..)) +import Database.SQLite.Simple.FromField (FieldParser, returnError) +import Database.SQLite.Simple.Internal (Field (..)) +import Database.SQLite.Simple.Ok (Ok (Ok)) +import Simplex.Messaging.Util ((<$?>)) +import Text.Read (readMaybe) + +base64P :: Parser ByteString +base64P = decode <$?> base64StringP + +base64StringP :: Parser ByteString +base64StringP = do + str <- A.takeWhile1 (\c -> isAlphaNum c || c == '+' || c == '/') + pad <- A.takeWhile (== '=') + pure $ str <> pad + +tsISO8601P :: Parser UTCTime +tsISO8601P = maybe (fail "timestamp") pure . parseISO8601 . B.unpack =<< A.takeTill (== ' ') + +parse :: Parser a -> e -> (ByteString -> Either e a) +parse parser err = first (const err) . parseAll parser + +parseAll :: Parser a -> (ByteString -> Either String a) +parseAll parser = A.parseOnly (parser <* A.endOfInput) + +parseRead :: Read a => Parser ByteString -> Parser a +parseRead = (>>= maybe (fail "cannot read") pure . readMaybe . B.unpack) + +parseRead1 :: Read a => Parser a +parseRead1 = parseRead $ A.takeTill (== ' ') + +parseRead2 :: Read a => Parser a +parseRead2 = parseRead $ do + w1 <- A.takeTill (== ' ') <* A.char ' ' + w2 <- A.takeTill (== ' ') + pure $ w1 <> " " <> w2 + +parseString :: (ByteString -> Either String a) -> (String -> a) +parseString p = either error id . p . B.pack + +blobFieldParser :: Typeable k => Parser k -> FieldParser k +blobFieldParser p = \case + f@(Field (SQLBlob b) _) -> + case parseAll p b of + Right k -> Ok k + Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e) + f -> returnError ConversionFailed f "expecting SQLBlob column type" diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/Simplex/Messaging/Protocol.hs @@ -0,0 +1,378 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} + +-- | +-- Module : Simplex.Messaging.Protocol +-- Copyright : (c) simplex.chat +-- License : AGPL-3 +-- +-- Maintainer : chat@simplex.chat +-- Stability : experimental +-- Portability : non-portable +-- +-- Types, parsers, serializers and functions to send and receive SMP protocol commands and responses. +-- +-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md +module Simplex.Messaging.Protocol + ( -- * SMP protocol types + Command (..), + Party (..), + Cmd (..), + SParty (..), + ErrorType (..), + CommandError (..), + Transmission, + SignedTransmission, + SignedTransmissionOrError, + RawTransmission, + SignedRawTransmission, + CorrId (..), + QueueId, + RecipientId, + SenderId, + RecipientPrivateKey, + RecipientPublicKey, + SenderPrivateKey, + SenderPublicKey, + Encoded, + MsgId, + MsgBody, + + -- * Parse and serialize + serializeTransmission, + serializeCommand, + serializeErrorType, + transmissionP, + commandP, + errorTypeP, + + -- * TCP transport functions + tPut, + tGet, + fromClient, + fromServer, + ) +where + +import Control.Applicative ((<|>)) +import Control.Monad +import Control.Monad.Except +import Data.Attoparsec.ByteString.Char8 (Parser) +import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.ByteString.Base64 +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Functor (($>)) +import Data.Kind +import Data.String +import Data.Time.Clock +import Data.Time.ISO8601 +import GHC.Generics (Generic) +import Generic.Random (genericArbitraryU) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Parsers +import Simplex.Messaging.Transport (THandle, TransportError (..), tGetEncrypted, tPutEncrypted) +import Simplex.Messaging.Util +import Test.QuickCheck (Arbitrary (..)) + +-- | SMP protocol participants. +data Party = Broker | Recipient | Sender + deriving (Show) + +-- | Singleton types for SMP protocol participants. +data SParty :: Party -> Type where + SBroker :: SParty Broker + SRecipient :: SParty Recipient + SSender :: SParty Sender + +deriving instance Show (SParty a) + +-- | Type for command or response of any participant. +data Cmd = forall a. Cmd (SParty a) (Command a) + +deriving instance Show Cmd + +-- | SMP transmission without signature. +type Transmission = (CorrId, QueueId, Cmd) + +-- | SMP transmission with signature. +type SignedTransmission = (C.Signature, Transmission) + +type TransmissionOrError = (CorrId, QueueId, Either ErrorType Cmd) + +-- | signed parsed transmission, with parsing error. +type SignedTransmissionOrError = (C.Signature, TransmissionOrError) + +-- | unparsed SMP transmission with signature. +type RawTransmission = (ByteString, ByteString, ByteString, ByteString) + +-- | unparsed SMP transmission with signature. +type SignedRawTransmission = (C.Signature, ByteString) + +-- | SMP queue ID for the recipient. +type RecipientId = QueueId + +-- | SMP queue ID for the sender. +type SenderId = QueueId + +-- | SMP queue ID on the server. +type QueueId = Encoded + +-- | Parameterized type for SMP protocol commands from all participants. +data Command (a :: Party) where + -- SMP recipient commands + NEW :: RecipientPublicKey -> Command Recipient + SUB :: Command Recipient + KEY :: SenderPublicKey -> Command Recipient + ACK :: Command Recipient + OFF :: Command Recipient + DEL :: Command Recipient + -- SMP sender commands + SEND :: MsgBody -> Command Sender + PING :: Command Sender + -- SMP broker commands (responses, messages, notifications) + IDS :: RecipientId -> SenderId -> Command Broker + MSG :: MsgId -> UTCTime -> MsgBody -> Command Broker + END :: Command Broker + OK :: Command Broker + ERR :: ErrorType -> Command Broker + PONG :: Command Broker + +deriving instance Show (Command a) + +deriving instance Eq (Command a) + +-- | Base-64 encoded string. +type Encoded = ByteString + +-- | Transmission correlation ID. +-- +-- A newtype to avoid accidentally changing order of transmission parts. +newtype CorrId = CorrId {bs :: ByteString} deriving (Eq, Ord, Show) + +instance IsString CorrId where + fromString = CorrId . fromString + +-- | Recipient's private key used by the recipient to authorize (sign) SMP commands. +-- +-- Only used by SMP agent, kept here so its definition is close to respective public key. +type RecipientPrivateKey = C.SafePrivateKey + +-- | Recipient's public key used by SMP server to verify authorization of SMP commands. +type RecipientPublicKey = C.PublicKey + +-- | Sender's private key used by the recipient to authorize (sign) SMP commands. +-- +-- Only used by SMP agent, kept here so its definition is close to respective public key. +type SenderPrivateKey = C.SafePrivateKey + +-- | Sender's public key used by SMP server to verify authorization of SMP commands. +type SenderPublicKey = C.PublicKey + +-- | SMP message server ID. +type MsgId = Encoded + +-- | SMP message body. +type MsgBody = ByteString + +-- | Type for protocol errors. +data ErrorType + = -- | incorrect block format, encoding or signature size + BLOCK + | -- | SMP command is unknown or has invalid syntax + CMD CommandError + | -- | command authorization error - bad signature or non-existing SMP queue + AUTH + | -- | ACK command is sent without message to be acknowledged + NO_MSG + | -- | internal server error + INTERNAL + | -- | used internally, never returned by the server (to be removed) + DUPLICATE_ -- TODO remove, not part of SMP protocol + deriving (Eq, Generic, Read, Show) + +-- | SMP command error type. +data CommandError + = -- | server response sent from client or vice versa + PROHIBITED + | -- | bad RSA key size in NEW or KEY commands (only 1024, 2048 and 4096 bits keys are allowed) + KEY_SIZE + | -- | error parsing command + SYNTAX + | -- | transmission has no required credentials (signature or queue ID) + NO_AUTH + | -- | transmission has credentials that are not allowed for this command + HAS_AUTH + | -- | transmission has no required queue ID + NO_QUEUE + deriving (Eq, Generic, Read, Show) + +instance Arbitrary ErrorType where arbitrary = genericArbitraryU + +instance Arbitrary CommandError where arbitrary = genericArbitraryU + +-- | SMP transmission parser. +transmissionP :: Parser RawTransmission +transmissionP = do + signature <- segment + corrId <- segment + queueId <- segment + command <- A.takeByteString + return (signature, corrId, queueId, command) + where + segment = A.takeTill (== ' ') <* " " + +-- | SMP command parser. +commandP :: Parser Cmd +commandP = + "NEW " *> newCmd + <|> "IDS " *> idsResp + <|> "SUB" $> Cmd SRecipient SUB + <|> "KEY " *> keyCmd + <|> "ACK" $> Cmd SRecipient ACK + <|> "OFF" $> Cmd SRecipient OFF + <|> "DEL" $> Cmd SRecipient DEL + <|> "SEND " *> sendCmd + <|> "PING" $> Cmd SSender PING + <|> "MSG " *> message + <|> "END" $> Cmd SBroker END + <|> "OK" $> Cmd SBroker OK + <|> "ERR " *> serverError + <|> "PONG" $> Cmd SBroker PONG + where + newCmd = Cmd SRecipient . NEW <$> C.pubKeyP + idsResp = Cmd SBroker <$> (IDS <$> (base64P <* A.space) <*> base64P) + keyCmd = Cmd SRecipient . KEY <$> C.pubKeyP + sendCmd = do + size <- A.decimal <* A.space + Cmd SSender . SEND <$> A.take size <* A.space + message = do + msgId <- base64P <* A.space + ts <- tsISO8601P <* A.space + size <- A.decimal <* A.space + Cmd SBroker . MSG msgId ts <$> A.take size <* A.space + serverError = Cmd SBroker . ERR <$> errorTypeP + +-- TODO ignore the end of block, no need to parse it + +-- | Parse SMP command. +parseCommand :: ByteString -> Either ErrorType Cmd +parseCommand = parse (commandP <* " " <* A.takeByteString) $ CMD SYNTAX + +-- | Serialize SMP command. +serializeCommand :: Cmd -> ByteString +serializeCommand = \case + Cmd SRecipient (NEW rKey) -> "NEW " <> C.serializePubKey rKey + Cmd SRecipient (KEY sKey) -> "KEY " <> C.serializePubKey sKey + Cmd SRecipient cmd -> bshow cmd + Cmd SSender (SEND msgBody) -> "SEND " <> serializeMsg msgBody + Cmd SSender PING -> "PING" + Cmd SBroker (MSG msgId ts msgBody) -> + B.unwords ["MSG", encode msgId, B.pack $ formatISO8601Millis ts, serializeMsg msgBody] + Cmd SBroker (IDS rId sId) -> B.unwords ["IDS", encode rId, encode sId] + Cmd SBroker (ERR err) -> "ERR " <> serializeErrorType err + Cmd SBroker resp -> bshow resp + where + serializeMsg msgBody = bshow (B.length msgBody) <> " " <> msgBody <> " " + +-- | SMP error parser. +errorTypeP :: Parser ErrorType +errorTypeP = "CMD " *> (CMD <$> parseRead1) <|> parseRead1 + +-- | Serialize SMP error. +serializeErrorType :: ErrorType -> ByteString +serializeErrorType = bshow + +-- | Send signed SMP transmission to TCP transport. +tPut :: THandle -> SignedRawTransmission -> IO (Either TransportError ()) +tPut th (C.Signature sig, t) = + tPutEncrypted th $ encode sig <> " " <> t <> " " + +-- | Serialize SMP transmission. +serializeTransmission :: Transmission -> ByteString +serializeTransmission (CorrId corrId, queueId, command) = + B.intercalate " " [corrId, encode queueId, serializeCommand command] + +-- | Validate that it is an SMP client command, used with 'tGet' by 'Simplex.Messaging.Server'. +fromClient :: Cmd -> Either ErrorType Cmd +fromClient = \case + Cmd SBroker _ -> Left $ CMD PROHIBITED + cmd -> Right cmd + +-- | Validate that it is an SMP server command, used with 'tGet' by 'Simplex.Messaging.Client'. +fromServer :: Cmd -> Either ErrorType Cmd +fromServer = \case + cmd@(Cmd SBroker _) -> Right cmd + _ -> Left $ CMD PROHIBITED + +-- | Receive and parse transmission from the TCP transport. +tGetParse :: THandle -> IO (Either TransportError RawTransmission) +tGetParse th = (>>= parse transmissionP TEBadBlock) <$> tGetEncrypted th + +-- | Receive client and server transmissions. +-- +-- The first argument is used to limit allowed senders. +-- 'fromClient' or 'fromServer' should be used here. +tGet :: forall m. MonadIO m => (Cmd -> Either ErrorType Cmd) -> THandle -> m SignedTransmissionOrError +tGet fromParty th = liftIO (tGetParse th) >>= decodeParseValidate + where + decodeParseValidate :: Either TransportError RawTransmission -> m SignedTransmissionOrError + decodeParseValidate = \case + Right (signature, corrId, queueId, command) -> + let decodedTransmission = liftM2 (,corrId,,command) (validSig =<< decode signature) (decode queueId) + in either (const $ tError corrId) tParseValidate decodedTransmission + Left _ -> tError "" + + validSig :: ByteString -> Either String ByteString + validSig sig + | B.null sig || C.validKeySize (B.length sig) = Right sig + | otherwise = Left "invalid signature size" + + tError :: ByteString -> m SignedTransmissionOrError + tError corrId = return (C.Signature "", (CorrId corrId, "", Left BLOCK)) + + tParseValidate :: RawTransmission -> m SignedTransmissionOrError + tParseValidate t@(sig, corrId, queueId, command) = do + let cmd = parseCommand command >>= fromParty >>= tCredentials t + return (C.Signature sig, (CorrId corrId, queueId, cmd)) + + tCredentials :: RawTransmission -> Cmd -> Either ErrorType Cmd + tCredentials (signature, _, queueId, _) cmd = case cmd of + -- IDS response must not have queue ID + Cmd SBroker (IDS _ _) -> Right cmd + -- ERR response does not always have queue ID + Cmd SBroker (ERR _) -> Right cmd + -- PONG response must not have queue ID + Cmd SBroker PONG + | B.null queueId -> Right cmd + | otherwise -> Left $ CMD HAS_AUTH + -- other responses must have queue ID + Cmd SBroker _ + | B.null queueId -> Left $ CMD NO_QUEUE + | otherwise -> Right cmd + -- NEW must have signature but NOT queue ID + Cmd SRecipient (NEW _) + | B.null signature -> Left $ CMD NO_AUTH + | not (B.null queueId) -> Left $ CMD HAS_AUTH + | otherwise -> Right cmd + -- SEND must have queue ID, signature is not always required + Cmd SSender (SEND _) + | B.null queueId -> Left $ CMD NO_QUEUE + | otherwise -> Right cmd + -- PING must not have queue ID or signature + Cmd SSender PING + | B.null queueId && B.null signature -> Right cmd + | otherwise -> Left $ CMD HAS_AUTH + -- other client commands must have both signature and queue ID + Cmd SRecipient _ + | B.null signature || B.null queueId -> Left $ CMD NO_AUTH + | otherwise -> Right cmd diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs new file mode 100644 --- /dev/null +++ b/src/Simplex/Messaging/Server.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Simplex.Messaging.Server +-- Copyright : (c) simplex.chat +-- License : AGPL-3 +-- +-- Maintainer : chat@simplex.chat +-- Stability : experimental +-- Portability : non-portable +-- +-- This module defines SMP protocol server with in-memory persistence +-- and optional append only log of SMP queue records. +-- +-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md +module Simplex.Messaging.Server (runSMPServer, runSMPServerBlocking) where + +import Control.Concurrent.STM (stateTVar) +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Unlift +import Control.Monad.Reader +import Crypto.Random +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Functor (($>)) +import qualified Data.Map.Strict as M +import Data.Time.Clock +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Protocol +import Simplex.Messaging.Server.Env.STM +import Simplex.Messaging.Server.MsgStore +import Simplex.Messaging.Server.MsgStore.STM (MsgQueue) +import Simplex.Messaging.Server.QueueStore +import Simplex.Messaging.Server.QueueStore.STM (QueueStore) +import Simplex.Messaging.Server.StoreLog +import Simplex.Messaging.Transport +import Simplex.Messaging.Util +import UnliftIO.Async +import UnliftIO.Concurrent +import UnliftIO.Exception +import UnliftIO.IO +import UnliftIO.STM + +-- | Runs an SMP server using passed configuration. +-- +-- See a full server here: https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-server/Main.hs +runSMPServer :: (MonadRandom m, MonadUnliftIO m) => ServerConfig -> m () +runSMPServer cfg = newEmptyTMVarIO >>= (`runSMPServerBlocking` cfg) + +-- | Runs an SMP server using passed configuration with signalling. +-- +-- This function uses passed TMVar to signal when the server is ready to accept TCP requests (True) +-- and when it is disconnected from the TCP socket once the server thread is killed (False). +runSMPServerBlocking :: (MonadRandom m, MonadUnliftIO m) => TMVar Bool -> ServerConfig -> m () +runSMPServerBlocking started cfg@ServerConfig {tcpPort} = do + env <- newEnv cfg + runReaderT smpServer env + where + smpServer :: (MonadUnliftIO m, MonadReader Env m) => m () + smpServer = do + s <- asks server + race_ (runTCPServer started tcpPort runClient) (serverThread s) + `finally` withLog closeStoreLog + + serverThread :: MonadUnliftIO m => Server -> m () + serverThread Server {subscribedQ, subscribers} = forever . atomically $ do + (rId, clnt) <- readTBQueue subscribedQ + cs <- readTVar subscribers + case M.lookup rId cs of + Just Client {rcvQ} -> writeTBQueue rcvQ (CorrId B.empty, rId, Cmd SBroker END) + Nothing -> return () + writeTVar subscribers $ M.insert rId clnt cs + +runClient :: (MonadUnliftIO m, MonadReader Env m) => Handle -> m () +runClient h = do + keyPair <- asks serverKeyPair + liftIO (runExceptT $ serverHandshake h keyPair) >>= \case + Right th -> runClientTransport th + Left _ -> pure () + +runClientTransport :: (MonadUnliftIO m, MonadReader Env m) => THandle -> m () +runClientTransport th = do + q <- asks $ tbqSize . config + c <- atomically $ newClient q + s <- asks server + raceAny_ [send th c, client c s, receive th c] + `finally` cancelSubscribers c + +cancelSubscribers :: MonadUnliftIO m => Client -> m () +cancelSubscribers Client {subscriptions} = + readTVarIO subscriptions >>= mapM_ cancelSub + +cancelSub :: MonadUnliftIO m => Sub -> m () +cancelSub = \case + Sub {subThread = SubThread t} -> killThread t + _ -> return () + +receive :: (MonadUnliftIO m, MonadReader Env m) => THandle -> Client -> m () +receive h Client {rcvQ} = forever $ do + (signature, (corrId, queueId, cmdOrError)) <- tGet fromClient h + t <- case cmdOrError of + Left e -> return . mkResp corrId queueId $ ERR e + Right cmd -> verifyTransmission (signature, (corrId, queueId, cmd)) + atomically $ writeTBQueue rcvQ t + +send :: MonadUnliftIO m => THandle -> Client -> m () +send h Client {sndQ} = forever $ do + t <- atomically $ readTBQueue sndQ + liftIO $ tPut h ("", serializeTransmission t) + +mkResp :: CorrId -> QueueId -> Command 'Broker -> Transmission +mkResp corrId queueId command = (corrId, queueId, Cmd SBroker command) + +verifyTransmission :: forall m. (MonadUnliftIO m, MonadReader Env m) => SignedTransmission -> m Transmission +verifyTransmission (sig, t@(corrId, queueId, cmd)) = do + (corrId,queueId,) <$> case cmd of + Cmd SBroker _ -> return $ smpErr INTERNAL -- it can only be client command, because `fromClient` was used + Cmd SRecipient (NEW k) -> pure $ verifySignature k + Cmd SRecipient _ -> verifyCmd SRecipient $ verifySignature . recipientKey + Cmd SSender (SEND _) -> verifyCmd SSender $ verifySend sig . senderKey + Cmd SSender PING -> return cmd + where + verifyCmd :: SParty p -> (QueueRec -> Cmd) -> m Cmd + verifyCmd party f = do + st <- asks queueStore + q <- atomically $ getQueue st party queueId + pure $ either (const $ dummyVerify authErr) f q + verifySend :: C.Signature -> Maybe SenderPublicKey -> Cmd + verifySend "" = maybe cmd (const authErr) + verifySend _ = maybe authErr verifySignature + verifySignature :: C.PublicKey -> Cmd + verifySignature key = if verify key then cmd else authErr + verify key + | C.publicKeySize key == sigLen = cryptoVerify key + | otherwise = dummyVerify False + cryptoVerify key = C.verify key sig (serializeTransmission t) + smpErr = Cmd SBroker . ERR + authErr = smpErr AUTH + dummyVerify :: a -> a + dummyVerify = seq $ + cryptoVerify $ case sigLen of + 128 -> dummyKey128 + 256 -> dummyKey256 + 512 -> dummyKey512 + _ -> dummyKey256 + sigLen = B.length $ C.unSignature sig + +-- These dummy keys are used with `dummyVerify` function to mitigate timing attacks +-- by having the same time of the response whether a queue exists or nor, for all valid key/signature sizes +dummyKey128 :: C.PublicKey +dummyKey128 = "MIIBIDANBgkqhkiG9w0BAQEFAAOCAQ0AMIIBCAKBgQC2oeA7s4roXN5K2N6022I1/2CTeMKjWH0m00bSZWa4N8LDKeFcShh8YUxZea5giAveViTRNOOVLgcuXbKvR3u24szN04xP0+KnYUuUUIIoT3YSjX0IlomhDhhSyup4BmA0gAZ+D1OaIKZFX6J8yQ1Lr/JGLEfSRsBjw8l+4hs9OwKBgQDKA+YlZvGb3BcpDwKmatiCXN7ZRDWkjXbj8VAW5zV95tSRCCVN48hrFM1H4Ju2QMMUc6kPUVX+eW4ZjdCl5blIqIHMcTmsdcmsDDCg3PjUNrwc6bv/1TcirbAKcmnKt9iurIt6eerxSO7TZUXXMUVsi7eRwb/RUNhpCrpJ/hpIOw==" + +dummyKey256 :: C.PublicKey +dummyKey256 = "MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAxwmTvaqmdTbkfUGNi8Yu0L/T4cxuOlQlx3zGZ9X9Qx0+oZjknWK+QHrdWTcpS+zH4Hi7fP6kanOQoQ90Hj6Ghl57VU1GEdUPywSw4i1/7t0Wv9uT9Q2ktHp2rqVo3xkC9IVIpL7EZAxdRviIN2OsOB3g4a/F1ZpjxcAaZeOMUugiAX1+GtkLuE0Xn4neYjCaOghLxQTdhybN70VtnkiQLx/X9NjkDIl/spYGm3tQFMyYKkP6IWoEpj0926hJ0fmlmhy8tAOhlZsb/baW5cgkEZ3E9jVVrySCgQzoLQgma610FIISRpRJbSyv26jU7MkMxiyuBiDaFOORkXFttoKbtQKBgEbDS9II2brsz+vfI7uP8atFcawkE52cx4M1UWQhqb1H3tBiRl+qO+dMq1pPQF2bW7dlZAWYzS4W/367bTAuALHBDGB8xi1P4Njhh9vaOgTvuqrHG9NJQ85BLy0qGw8rjIWSIXVmVpfrXFJ8po5l04UE258Ll2yocv3QRQmddQW9" + +dummyKey512 :: C.PublicKey +dummyKey512 = "MIICoDANBgkqhkiG9w0BAQEFAAOCAo0AMIICiAKCAgEArkCY9DuverJ4mmzDektv9aZMFyeRV46WZK9NsOBKEc+1ncqMs+LhLti9asKNgUBRbNzmbOe0NYYftrUpwnATaenggkTFxxbJ4JGJuGYbsEdFWkXSvrbWGtM8YUmn5RkAGme12xQ89bSM4VoJAGnrYPHwmcQd+KYCPZvTUsxaxgrJTX65ejHN9BsAn8XtGViOtHTDJO9yUMD2WrJvd7wnNa+0ugEteDLzMU++xS98VC+uA1vfauUqi3yXVchdfrLdVUuM+JE0gUEXCgzjuHkaoHiaGNiGhdPYoAJJdOKQOIHAKdk7Th6OPhirPhc9XYNB4O8JDthKhNtfokvFIFlC4QBRzJhpLIENaEBDt08WmgpOnecZB/CuxkqqOrNa8j5K5jNrtXAI67W46VEC2jeQy/gZwb64Zit2A4D00xXzGbQTPGj4ehcEMhLx5LSCygViEf0w0tN3c3TEyUcgPzvECd2ZVpQLr9Z4a07Ebr+YSuxcHhjg4Rg1VyJyOTTvaCBGm5X2B3+tI4NUttmikIHOYpBnsLmHY2BgfH2KcrIsDyAhInXmTFr/L2+erFarUnlfATd2L8Ti43TNHDedO6k6jI5Gyi62yPwjqPLEIIK8l+pIeNfHJ3pPmjhHBfzFcQLMMMXffHWNK8kWklrQXK+4j4HiPcTBvlO1FEtG9nEIZhUCgYA4a6WtI2k5YNli1C89GY5rGUY7RP71T6RWri/D3Lz9T7GvU+FemAyYmsvCQwqijUOur0uLvwSP8VdxpSUcrjJJSWur2hrPWzWlu0XbNaeizxpFeKbQP+zSrWJ1z8RwfAeUjShxt8q1TuqGqY10wQyp3nyiTGvS+KwZVj5h5qx8NQ==" + +client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server -> m () +client clnt@Client {subscriptions, rcvQ, sndQ} Server {subscribedQ} = + forever $ + atomically (readTBQueue rcvQ) + >>= processCommand + >>= atomically . writeTBQueue sndQ + where + processCommand :: Transmission -> m Transmission + processCommand (corrId, queueId, cmd) = do + st <- asks queueStore + case cmd of + Cmd SBroker END -> unsubscribeQueue $> (corrId, queueId, cmd) + Cmd SBroker _ -> return (corrId, queueId, cmd) + Cmd SSender command -> case command of + SEND msgBody -> sendMessage st msgBody + PING -> return (corrId, queueId, Cmd SBroker PONG) + Cmd SRecipient command -> case command of + NEW rKey -> createQueue st rKey + SUB -> subscribeQueue queueId + ACK -> acknowledgeMsg + KEY sKey -> secureQueue_ st sKey + OFF -> suspendQueue_ st + DEL -> delQueueAndMsgs st + where + createQueue :: QueueStore -> RecipientPublicKey -> m Transmission + createQueue st rKey = + checkKeySize rKey addSubscribe + where + addSubscribe = + addQueueRetry 3 >>= \case + Left e -> return $ ERR e + Right (rId, sId) -> do + withLog (`logCreateById` rId) + subscribeQueue rId $> IDS rId sId + + addQueueRetry :: Int -> m (Either ErrorType (RecipientId, SenderId)) + addQueueRetry 0 = return $ Left INTERNAL + addQueueRetry n = do + ids <- getIds + atomically (addQueue st rKey ids) >>= \case + Left DUPLICATE_ -> addQueueRetry $ n - 1 + Left e -> return $ Left e + Right _ -> return $ Right ids + + logCreateById :: StoreLog 'WriteMode -> RecipientId -> IO () + logCreateById s rId = + atomically (getQueue st SRecipient rId) >>= \case + Right q -> logCreateQueue s q + _ -> pure () + + getIds :: m (RecipientId, SenderId) + getIds = do + n <- asks $ queueIdBytes . config + liftM2 (,) (randomId n) (randomId n) + + secureQueue_ :: QueueStore -> SenderPublicKey -> m Transmission + secureQueue_ st sKey = do + withLog $ \s -> logSecureQueue s queueId sKey + atomically . checkKeySize sKey $ either ERR (const OK) <$> secureQueue st queueId sKey + + checkKeySize :: Monad m' => C.PublicKey -> m' (Command 'Broker) -> m' Transmission + checkKeySize key action = + mkResp corrId queueId + <$> if C.validKeySize $ C.publicKeySize key + then action + else pure . ERR $ CMD KEY_SIZE + + suspendQueue_ :: QueueStore -> m Transmission + suspendQueue_ st = do + withLog (`logDeleteQueue` queueId) + okResp <$> atomically (suspendQueue st queueId) + + subscribeQueue :: RecipientId -> m Transmission + subscribeQueue rId = + atomically (getSubscription rId) >>= deliverMessage tryPeekMsg rId + + getSubscription :: RecipientId -> STM Sub + getSubscription rId = do + subs <- readTVar subscriptions + case M.lookup rId subs of + Just s -> tryTakeTMVar (delivered s) $> s + Nothing -> do + writeTBQueue subscribedQ (rId, clnt) + s <- newSubscription + writeTVar subscriptions $ M.insert rId s subs + return s + + unsubscribeQueue :: m () + unsubscribeQueue = do + sub <- atomically . stateTVar subscriptions $ + \cs -> (M.lookup queueId cs, M.delete queueId cs) + mapM_ cancelSub sub + + acknowledgeMsg :: m Transmission + acknowledgeMsg = + atomically (withSub queueId $ \s -> const s <$$> tryTakeTMVar (delivered s)) + >>= \case + Just (Just s) -> deliverMessage tryDelPeekMsg queueId s + _ -> return $ err NO_MSG + + withSub :: RecipientId -> (Sub -> STM a) -> STM (Maybe a) + withSub rId f = readTVar subscriptions >>= mapM f . M.lookup rId + + sendMessage :: QueueStore -> MsgBody -> m Transmission + sendMessage st msgBody = do + qr <- atomically $ getQueue st SSender queueId + either (return . err) storeMessage qr + where + mkMessage :: m Message + mkMessage = do + msgId <- asks (msgIdBytes . config) >>= randomId + ts <- liftIO getCurrentTime + return $ Message {msgId, ts, msgBody} + + storeMessage :: QueueRec -> m Transmission + storeMessage qr = case status qr of + QueueOff -> return $ err AUTH + QueueActive -> do + ms <- asks msgStore + msg <- mkMessage + atomically $ do + q <- getMsgQueue ms (recipientId qr) + writeMsg q msg + return ok + + deliverMessage :: (MsgQueue -> STM (Maybe Message)) -> RecipientId -> Sub -> m Transmission + deliverMessage tryPeek rId = \case + Sub {subThread = NoSub} -> do + ms <- asks msgStore + q <- atomically $ getMsgQueue ms rId + atomically (tryPeek q) >>= \case + Nothing -> forkSub q $> ok + Just msg -> atomically setDelivered $> mkResp corrId rId (msgCmd msg) + _ -> return ok + where + forkSub :: MsgQueue -> m () + forkSub q = do + atomically . setSub $ \s -> s {subThread = SubPending} + t <- forkIO $ subscriber q + atomically . setSub $ \case + s@Sub {subThread = SubPending} -> s {subThread = SubThread t} + s -> s + + subscriber :: MsgQueue -> m () + subscriber q = atomically $ do + msg <- peekMsg q + writeTBQueue sndQ $ mkResp (CorrId B.empty) rId (msgCmd msg) + setSub (\s -> s {subThread = NoSub}) + void setDelivered + + setSub :: (Sub -> Sub) -> STM () + setSub f = modifyTVar subscriptions $ M.adjust f rId + + setDelivered :: STM (Maybe Bool) + setDelivered = withSub rId $ \s -> tryPutTMVar (delivered s) () + + delQueueAndMsgs :: QueueStore -> m Transmission + delQueueAndMsgs st = do + withLog (`logDeleteQueue` queueId) + ms <- asks msgStore + atomically $ + deleteQueue st queueId >>= \case + Left e -> return $ err e + Right _ -> delMsgQueue ms queueId $> ok + + ok :: Transmission + ok = mkResp corrId queueId OK + + err :: ErrorType -> Transmission + err = mkResp corrId queueId . ERR + + okResp :: Either ErrorType () -> Transmission + okResp = either err $ const ok + + msgCmd :: Message -> Command 'Broker + msgCmd Message {msgId, ts, msgBody} = MSG msgId ts msgBody + +withLog :: (MonadUnliftIO m, MonadReader Env m) => (StoreLog 'WriteMode -> IO a) -> m () +withLog action = do + env <- ask + liftIO . mapM_ action $ storeLog (env :: Env) + +randomId :: (MonadUnliftIO m, MonadReader Env m) => Int -> m Encoded +randomId n = do + gVar <- asks idsDrg + atomically (randomBytes n gVar) + +randomBytes :: Int -> TVar ChaChaDRG -> STM ByteString +randomBytes n gVar = do + g <- readTVar gVar + let (bytes, g') = randomBytesGenerate n g + writeTVar gVar g' + return bytes diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs new file mode 100644 --- /dev/null +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Simplex.Messaging.Server.Env.STM where + +import Control.Concurrent (ThreadId) +import Control.Monad.IO.Unlift +import Crypto.Random +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Network.Socket (ServiceName) +import Numeric.Natural +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Protocol +import Simplex.Messaging.Server.MsgStore.STM +import Simplex.Messaging.Server.QueueStore (QueueRec (..)) +import Simplex.Messaging.Server.QueueStore.STM +import Simplex.Messaging.Server.StoreLog +import System.IO (IOMode (..)) +import UnliftIO.STM + +data ServerConfig = ServerConfig + { tcpPort :: ServiceName, + tbqSize :: Natural, + queueIdBytes :: Int, + msgIdBytes :: Int, + storeLog :: Maybe (StoreLog 'ReadMode), + serverPrivateKey :: C.FullPrivateKey + -- serverId :: ByteString + } + +data Env = Env + { config :: ServerConfig, + server :: Server, + queueStore :: QueueStore, + msgStore :: STMMsgStore, + idsDrg :: TVar ChaChaDRG, + serverKeyPair :: C.FullKeyPair, + storeLog :: Maybe (StoreLog 'WriteMode) + } + +data Server = Server + { subscribedQ :: TBQueue (RecipientId, Client), + subscribers :: TVar (Map RecipientId Client) + } + +data Client = Client + { subscriptions :: TVar (Map RecipientId Sub), + rcvQ :: TBQueue Transmission, + sndQ :: TBQueue Transmission + } + +data SubscriptionThread = NoSub | SubPending | SubThread ThreadId + +data Sub = Sub + { subThread :: SubscriptionThread, + delivered :: TMVar () + } + +newServer :: Natural -> STM Server +newServer qSize = do + subscribedQ <- newTBQueue qSize + subscribers <- newTVar M.empty + return Server {subscribedQ, subscribers} + +newClient :: Natural -> STM Client +newClient qSize = do + subscriptions <- newTVar M.empty + rcvQ <- newTBQueue qSize + sndQ <- newTBQueue qSize + return Client {subscriptions, rcvQ, sndQ} + +newSubscription :: STM Sub +newSubscription = do + delivered <- newEmptyTMVar + return Sub {subThread = NoSub, delivered} + +newEnv :: forall m. (MonadUnliftIO m, MonadRandom m) => ServerConfig -> m Env +newEnv config = do + server <- atomically $ newServer (tbqSize config) + queueStore <- atomically newQueueStore + msgStore <- atomically newMsgStore + idsDrg <- drgNew >>= newTVarIO + s' <- restoreQueues queueStore `mapM` storeLog (config :: ServerConfig) + let pk = serverPrivateKey config + serverKeyPair = (C.publicKey pk, pk) + return Env {config, server, queueStore, msgStore, idsDrg, serverKeyPair, storeLog = s'} + where + restoreQueues :: QueueStore -> StoreLog 'ReadMode -> m (StoreLog 'WriteMode) + restoreQueues queueStore s = do + (queues, s') <- liftIO $ readWriteStoreLog s + atomically $ modifyTVar queueStore $ \d -> d {queues, senders = M.foldr' addSender M.empty queues} + pure s' + addSender :: QueueRec -> Map SenderId RecipientId -> Map SenderId RecipientId + addSender q = M.insert (senderId q) (recipientId q) diff --git a/src/Simplex/Messaging/Server/MsgStore.hs b/src/Simplex/Messaging/Server/MsgStore.hs new file mode 100644 --- /dev/null +++ b/src/Simplex/Messaging/Server/MsgStore.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE FunctionalDependencies #-} + +module Simplex.Messaging.Server.MsgStore where + +import Data.Time.Clock +import Simplex.Messaging.Protocol (Encoded, MsgBody, RecipientId) + +data Message = Message + { msgId :: Encoded, + ts :: UTCTime, + msgBody :: MsgBody + } + +class MonadMsgStore s q m | s -> q where + getMsgQueue :: s -> RecipientId -> m q + delMsgQueue :: s -> RecipientId -> m () + +class MonadMsgQueue q m where + writeMsg :: q -> Message -> m () -- non blocking + tryPeekMsg :: q -> m (Maybe Message) -- non blocking + peekMsg :: q -> m Message -- blocking + tryDelPeekMsg :: q -> m (Maybe Message) -- atomic delete (== read) last and peek next message, if available diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs new file mode 100644 --- /dev/null +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Simplex.Messaging.Server.MsgStore.STM where + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Simplex.Messaging.Protocol (RecipientId) +import Simplex.Messaging.Server.MsgStore +import UnliftIO.STM + +newtype MsgQueue = MsgQueue {msgQueue :: TQueue Message} + +newtype MsgStoreData = MsgStoreData {messages :: Map RecipientId MsgQueue} + +type STMMsgStore = TVar MsgStoreData + +newMsgStore :: STM STMMsgStore +newMsgStore = newTVar $ MsgStoreData M.empty + +instance MonadMsgStore STMMsgStore MsgQueue STM where + getMsgQueue :: STMMsgStore -> RecipientId -> STM MsgQueue + getMsgQueue store rId = do + m <- messages <$> readTVar store + maybe (newQ m) return $ M.lookup rId m + where + newQ m' = do + q <- MsgQueue <$> newTQueue + writeTVar store . MsgStoreData $ M.insert rId q m' + return q + + delMsgQueue :: STMMsgStore -> RecipientId -> STM () + delMsgQueue store rId = + modifyTVar store $ MsgStoreData . M.delete rId . messages + +instance MonadMsgQueue MsgQueue STM where + writeMsg :: MsgQueue -> Message -> STM () + writeMsg = writeTQueue . msgQueue + + tryPeekMsg :: MsgQueue -> STM (Maybe Message) + tryPeekMsg = tryPeekTQueue . msgQueue + + peekMsg :: MsgQueue -> STM Message + peekMsg = peekTQueue . msgQueue + + -- atomic delete (== read) last and peek next message if available + tryDelPeekMsg :: MsgQueue -> STM (Maybe Message) + tryDelPeekMsg (MsgQueue q) = tryReadTQueue q >> tryPeekTQueue q diff --git a/src/Simplex/Messaging/Server/QueueStore.hs b/src/Simplex/Messaging/Server/QueueStore.hs new file mode 100644 --- /dev/null +++ b/src/Simplex/Messaging/Server/QueueStore.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Simplex.Messaging.Server.QueueStore where + +import Simplex.Messaging.Protocol + +data QueueRec = QueueRec + { recipientId :: QueueId, + senderId :: QueueId, + recipientKey :: RecipientPublicKey, + senderKey :: Maybe SenderPublicKey, + status :: QueueStatus + } + +data QueueStatus = QueueActive | QueueOff deriving (Eq) + +class MonadQueueStore s m where + addQueue :: s -> RecipientPublicKey -> (RecipientId, SenderId) -> m (Either ErrorType ()) + getQueue :: s -> SParty (a :: Party) -> QueueId -> m (Either ErrorType QueueRec) + secureQueue :: s -> RecipientId -> SenderPublicKey -> m (Either ErrorType ()) + suspendQueue :: s -> RecipientId -> m (Either ErrorType ()) + deleteQueue :: s -> RecipientId -> m (Either ErrorType ()) + +mkQueueRec :: RecipientPublicKey -> (RecipientId, SenderId) -> QueueRec +mkQueueRec recipientKey (recipientId, senderId) = + QueueRec + { recipientId, + senderId, + recipientKey, + senderKey = Nothing, + status = QueueActive + } diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs new file mode 100644 --- /dev/null +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +module Simplex.Messaging.Server.QueueStore.STM where + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Simplex.Messaging.Protocol +import Simplex.Messaging.Server.QueueStore +import UnliftIO.STM + +data QueueStoreData = QueueStoreData + { queues :: Map RecipientId QueueRec, + senders :: Map SenderId RecipientId + } + +type QueueStore = TVar QueueStoreData + +newQueueStore :: STM QueueStore +newQueueStore = newTVar QueueStoreData {queues = M.empty, senders = M.empty} + +instance MonadQueueStore QueueStore STM where + addQueue :: QueueStore -> RecipientPublicKey -> (RecipientId, SenderId) -> STM (Either ErrorType ()) + addQueue store rKey ids@(rId, sId) = do + cs@QueueStoreData {queues, senders} <- readTVar store + if M.member rId queues || M.member sId senders + then return $ Left DUPLICATE_ + else do + writeTVar store $ + cs + { queues = M.insert rId (mkQueueRec rKey ids) queues, + senders = M.insert sId rId senders + } + return $ Right () + + getQueue :: QueueStore -> SParty (p :: Party) -> QueueId -> STM (Either ErrorType QueueRec) + getQueue store SRecipient rId = do + cs <- readTVar store + return $ getRcpQueue cs rId + getQueue store SSender sId = do + cs <- readTVar store + let rId = M.lookup sId $ senders cs + return $ maybe (Left AUTH) (getRcpQueue cs) rId + getQueue _ SBroker _ = + return $ Left INTERNAL + + secureQueue store rId sKey = + updateQueues store rId $ \cs c -> + case senderKey c of + Just _ -> (Left AUTH, cs) + _ -> (Right (), cs {queues = M.insert rId c {senderKey = Just sKey} (queues cs)}) + + suspendQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ()) + suspendQueue store rId = + updateQueues store rId $ \cs c -> + (Right (), cs {queues = M.insert rId c {status = QueueOff} (queues cs)}) + + deleteQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ()) + deleteQueue store rId = + updateQueues store rId $ \cs c -> + ( Right (), + cs + { queues = M.delete rId (queues cs), + senders = M.delete (senderId c) (senders cs) + } + ) + +updateQueues :: + QueueStore -> + RecipientId -> + (QueueStoreData -> QueueRec -> (Either ErrorType (), QueueStoreData)) -> + STM (Either ErrorType ()) +updateQueues store rId update = do + cs <- readTVar store + let conn = getRcpQueue cs rId + either (return . Left) (_update cs) conn + where + _update cs c = do + let (res, cs') = update cs c + writeTVar store cs' + return res + +getRcpQueue :: QueueStoreData -> RecipientId -> Either ErrorType QueueRec +getRcpQueue cs rId = maybe (Left AUTH) Right . M.lookup rId $ queues cs diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs new file mode 100644 --- /dev/null +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Simplex.Messaging.Server.StoreLog + ( StoreLog, -- constructors are not exported + openWriteStoreLog, + openReadStoreLog, + closeStoreLog, + logCreateQueue, + logSecureQueue, + logDeleteQueue, + readWriteStoreLog, + ) +where + +import Control.Applicative (optional, (<|>)) +import Control.Monad (unless) +import Data.Attoparsec.ByteString.Char8 (Parser) +import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.Bifunctor (first, second) +import Data.ByteString.Base64 (encode) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Either (partitionEithers) +import Data.Functor (($>)) +import Data.List (foldl') +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Parsers (base64P, parseAll) +import Simplex.Messaging.Protocol +import Simplex.Messaging.Server.QueueStore (QueueRec (..), QueueStatus (..)) +import Simplex.Messaging.Transport (trimCR) +import System.Directory (doesFileExist) +import System.IO + +-- | opaque container for file handle with a type-safe IOMode +-- constructors are not exported, openWriteStoreLog and openReadStoreLog should be used instead +data StoreLog (a :: IOMode) where + ReadStoreLog :: FilePath -> Handle -> StoreLog 'ReadMode + WriteStoreLog :: FilePath -> Handle -> StoreLog 'WriteMode + +data StoreLogRecord + = CreateQueue QueueRec + | SecureQueue QueueId SenderPublicKey + | DeleteQueue QueueId + +storeLogRecordP :: Parser StoreLogRecord +storeLogRecordP = + "CREATE " *> createQueueP + <|> "SECURE " *> secureQueueP + <|> "DELETE " *> (DeleteQueue <$> base64P) + where + createQueueP = CreateQueue <$> queueRecP + secureQueueP = SecureQueue <$> base64P <* A.space <*> C.pubKeyP + queueRecP = do + recipientId <- "rid=" *> base64P <* A.space + senderId <- "sid=" *> base64P <* A.space + recipientKey <- "rk=" *> C.pubKeyP <* A.space + senderKey <- "sk=" *> optional C.pubKeyP + pure QueueRec {recipientId, senderId, recipientKey, senderKey, status = QueueActive} + +serializeStoreLogRecord :: StoreLogRecord -> ByteString +serializeStoreLogRecord = \case + CreateQueue q -> "CREATE " <> serializeQueue q + SecureQueue rId sKey -> "SECURE " <> encode rId <> " " <> C.serializePubKey sKey + DeleteQueue rId -> "DELETE " <> encode rId + where + serializeQueue QueueRec {recipientId, senderId, recipientKey, senderKey} = + B.unwords + [ "rid=" <> encode recipientId, + "sid=" <> encode senderId, + "rk=" <> C.serializePubKey recipientKey, + "sk=" <> maybe "" C.serializePubKey senderKey + ] + +openWriteStoreLog :: FilePath -> IO (StoreLog 'WriteMode) +openWriteStoreLog f = WriteStoreLog f <$> openFile f WriteMode + +openReadStoreLog :: FilePath -> IO (StoreLog 'ReadMode) +openReadStoreLog f = do + doesFileExist f >>= (`unless` writeFile f "") + ReadStoreLog f <$> openFile f ReadMode + +closeStoreLog :: StoreLog a -> IO () +closeStoreLog = \case + WriteStoreLog _ h -> hClose h + ReadStoreLog _ h -> hClose h + +writeStoreLogRecord :: StoreLog 'WriteMode -> StoreLogRecord -> IO () +writeStoreLogRecord (WriteStoreLog _ h) r = do + B.hPutStrLn h $ serializeStoreLogRecord r + hFlush h + +logCreateQueue :: StoreLog 'WriteMode -> QueueRec -> IO () +logCreateQueue s = writeStoreLogRecord s . CreateQueue + +logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SenderPublicKey -> IO () +logSecureQueue s qId sKey = writeStoreLogRecord s $ SecureQueue qId sKey + +logDeleteQueue :: StoreLog 'WriteMode -> QueueId -> IO () +logDeleteQueue s = writeStoreLogRecord s . DeleteQueue + +readWriteStoreLog :: StoreLog 'ReadMode -> IO (Map RecipientId QueueRec, StoreLog 'WriteMode) +readWriteStoreLog s@(ReadStoreLog f _) = do + qs <- readQueues s + closeStoreLog s + s' <- openWriteStoreLog f + writeQueues s' qs + pure (qs, s') + +writeQueues :: StoreLog 'WriteMode -> Map RecipientId QueueRec -> IO () +writeQueues s = mapM_ (writeStoreLogRecord s . CreateQueue) . M.filter active + where + active QueueRec {status} = status == QueueActive + +type LogParsingError = (String, ByteString) + +readQueues :: StoreLog 'ReadMode -> IO (Map RecipientId QueueRec) +readQueues (ReadStoreLog _ h) = LB.hGetContents h >>= returnResult . procStoreLog + where + procStoreLog :: LB.ByteString -> ([LogParsingError], Map RecipientId QueueRec) + procStoreLog = second (foldl' procLogRecord M.empty) . partitionEithers . map parseLogRecord . LB.lines + returnResult :: ([LogParsingError], Map RecipientId QueueRec) -> IO (Map RecipientId QueueRec) + returnResult (errs, res) = mapM_ printError errs $> res + parseLogRecord :: LB.ByteString -> Either LogParsingError StoreLogRecord + parseLogRecord = (\s -> first (,s) $ parseAll storeLogRecordP s) . trimCR . LB.toStrict + procLogRecord :: Map RecipientId QueueRec -> StoreLogRecord -> Map RecipientId QueueRec + procLogRecord m = \case + CreateQueue q -> M.insert (recipientId q) q m + SecureQueue qId sKey -> M.adjust (\q -> q {senderKey = Just sKey}) qId m + DeleteQueue qId -> M.delete qId m + printError :: LogParsingError -> IO () + printError (e, s) = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs new file mode 100644 --- /dev/null +++ b/src/Simplex/Messaging/Transport.hs @@ -0,0 +1,441 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Simplex.Messaging.Transport +-- Copyright : (c) simplex.chat +-- License : AGPL-3 +-- +-- Maintainer : chat@simplex.chat +-- Stability : experimental +-- Portability : non-portable +-- +-- This module defines basic TCP server and client and SMP protocol encrypted transport over TCP. +-- +-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a +module Simplex.Messaging.Transport + ( -- * TCP transport + runTCPServer, + runTCPClient, + putLn, + getLn, + trimCR, + + -- * SMP encrypted transport + THandle (..), + TransportError (..), + serverHandshake, + clientHandshake, + tPutEncrypted, + tGetEncrypted, + serializeTransportError, + transportErrorP, + ) +where + +import Control.Applicative ((<|>)) +import Control.Monad.Except +import Control.Monad.IO.Unlift +import Control.Monad.Trans.Except (throwE) +import Crypto.Cipher.Types (AuthTag) +import Data.Attoparsec.ByteString.Char8 (Parser) +import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.Bifunctor (first) +import Data.ByteArray (xor) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Functor (($>)) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Word (Word32) +import GHC.Generics (Generic) +import GHC.IO.Exception (IOErrorType (..)) +import GHC.IO.Handle.Internals (ioe_EOF) +import Generic.Random (genericArbitraryU) +import Network.Socket +import Network.Transport.Internal (decodeNum16, decodeNum32, encodeEnum16, encodeEnum32, encodeWord32) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Parsers (parse, parseAll, parseRead1) +import Simplex.Messaging.Util (bshow, liftError) +import System.IO +import System.IO.Error +import Test.QuickCheck (Arbitrary (..)) +import UnliftIO.Concurrent +import UnliftIO.Exception (Exception, IOException) +import qualified UnliftIO.Exception as E +import qualified UnliftIO.IO as IO +import UnliftIO.STM + +-- * TCP transport + +-- | Run TCP server on passed port and signal when server started and stopped via passed TMVar. +-- +-- All accepted TCP connection handles are passed to the passed function. +runTCPServer :: MonadUnliftIO m => TMVar Bool -> ServiceName -> (Handle -> m ()) -> m () +runTCPServer started port server = do + clients <- newTVarIO S.empty + E.bracket (liftIO $ startTCPServer started port) (liftIO . closeServer clients) \sock -> forever $ do + h <- liftIO $ acceptTCPConn sock + tid <- forkFinally (server h) (const $ IO.hClose h) + atomically . modifyTVar clients $ S.insert tid + where + closeServer :: TVar (Set ThreadId) -> Socket -> IO () + closeServer clients sock = do + readTVarIO clients >>= mapM_ killThread + close sock + void . atomically $ tryPutTMVar started False + +startTCPServer :: TMVar Bool -> ServiceName -> IO Socket +startTCPServer started port = withSocketsDo $ resolve >>= open >>= setStarted + where + resolve = + let hints = defaultHints {addrFlags = [AI_PASSIVE], addrSocketType = Stream} + in head <$> getAddrInfo (Just hints) Nothing (Just port) + open addr = do + sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + setSocketOption sock ReuseAddr 1 + withFdSocket sock setCloseOnExecIfNeeded + bind sock $ addrAddress addr + listen sock 1024 + return sock + setStarted sock = atomically (putTMVar started True) >> pure sock + +acceptTCPConn :: Socket -> IO Handle +acceptTCPConn sock = accept sock >>= getSocketHandle . fst + +-- | Connect to passed TCP host:port and pass handle to the client. +runTCPClient :: MonadUnliftIO m => HostName -> ServiceName -> (Handle -> m a) -> m a +runTCPClient host port client = do + h <- liftIO $ startTCPClient host port + client h `E.finally` IO.hClose h + +startTCPClient :: HostName -> ServiceName -> IO Handle +startTCPClient host port = withSocketsDo $ resolve >>= tryOpen err + where + err :: IOException + err = mkIOError NoSuchThing "no address" Nothing Nothing + + resolve :: IO [AddrInfo] + resolve = + let hints = defaultHints {addrSocketType = Stream} + in getAddrInfo (Just hints) (Just host) (Just port) + + tryOpen :: IOException -> [AddrInfo] -> IO Handle + tryOpen e [] = E.throwIO e + tryOpen _ (addr : as) = + E.try (open addr) >>= either (`tryOpen` as) pure + + open :: AddrInfo -> IO Handle + open addr = do + sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + connect sock $ addrAddress addr + getSocketHandle sock + +getSocketHandle :: Socket -> IO Handle +getSocketHandle conn = do + h <- socketToHandle conn ReadWriteMode + hSetBinaryMode h True + hSetNewlineMode h NewlineMode {inputNL = CRLF, outputNL = CRLF} + hSetBuffering h LineBuffering + return h + +-- | Send ByteString to TCP connection handle terminating it with CRLF. +putLn :: Handle -> ByteString -> IO () +putLn h = B.hPut h . (<> "\r\n") + +-- | Receive ByteString from TCP connection handle, allowing LF or CRLF termination. +getLn :: Handle -> IO ByteString +getLn h = trimCR <$> B.hGetLine h + +-- | Trim trailing CR from ByteString. +trimCR :: ByteString -> ByteString +trimCR "" = "" +trimCR s = if B.last s == '\r' then B.init s else s + +-- * SMP encrypted transport + +data SMPVersion = SMPVersion Int Int Int Int + deriving (Eq, Ord) + +major :: SMPVersion -> (Int, Int) +major (SMPVersion a b _ _) = (a, b) + +currentSMPVersion :: SMPVersion +currentSMPVersion = SMPVersion 0 3 1 0 + +serializeSMPVersion :: SMPVersion -> ByteString +serializeSMPVersion (SMPVersion a b c d) = B.intercalate "." [bshow a, bshow b, bshow c, bshow d] + +smpVersionP :: Parser SMPVersion +smpVersionP = + let ver = A.decimal <* A.char '.' + in SMPVersion <$> ver <*> ver <*> ver <*> A.decimal + +-- | The handle for SMP encrypted transport connection over TCP. +data THandle = THandle + { handle :: Handle, + sndKey :: SessionKey, + rcvKey :: SessionKey, + blockSize :: Int + } + +data SessionKey = SessionKey + { aesKey :: C.Key, + baseIV :: C.IV, + counter :: TVar Word32 + } + +data ClientHandshake = ClientHandshake + { blockSize :: Int, + sndKey :: SessionKey, + rcvKey :: SessionKey + } + +-- | Error of SMP encrypted transport over TCP. +data TransportError + = -- | error parsing transport block + TEBadBlock + | -- | block encryption error + TEEncrypt + | -- | block decryption error + TEDecrypt + | -- | transport handshake error + TEHandshake HandshakeError + deriving (Eq, Generic, Read, Show, Exception) + +-- | Transport handshake error. +data HandshakeError + = -- | encryption error + ENCRYPT + | -- | decryption error + DECRYPT + | -- | error parsing protocol version + VERSION + | -- | error parsing RSA key + RSA_KEY + | -- | error parsing server transport header or invalid block size + HEADER + | -- | error parsing AES keys + AES_KEYS + | -- | not matching RSA key hash + BAD_HASH + | -- | lower major agent version than protocol version + MAJOR_VERSION + | -- | TCP transport terminated + TERMINATED + deriving (Eq, Generic, Read, Show, Exception) + +instance Arbitrary TransportError where arbitrary = genericArbitraryU + +instance Arbitrary HandshakeError where arbitrary = genericArbitraryU + +-- | SMP encrypted transport error parser. +transportErrorP :: Parser TransportError +transportErrorP = + "BLOCK" $> TEBadBlock + <|> "AES_ENCRYPT" $> TEEncrypt + <|> "AES_DECRYPT" $> TEDecrypt + <|> TEHandshake <$> parseRead1 + +-- | Serialize SMP encrypted transport error. +serializeTransportError :: TransportError -> ByteString +serializeTransportError = \case + TEEncrypt -> "AES_ENCRYPT" + TEDecrypt -> "AES_DECRYPT" + TEBadBlock -> "BLOCK" + TEHandshake e -> bshow e + +-- | Encrypt and send block to SMP encrypted transport. +tPutEncrypted :: THandle -> ByteString -> IO (Either TransportError ()) +tPutEncrypted THandle {handle = h, sndKey, blockSize} block = + encryptBlock sndKey (blockSize - C.authTagSize) block >>= \case + Left _ -> pure $ Left TEEncrypt + Right (authTag, msg) -> Right <$> B.hPut h (C.authTagToBS authTag <> msg) + +-- | Receive and decrypt block from SMP encrypted transport. +tGetEncrypted :: THandle -> IO (Either TransportError ByteString) +tGetEncrypted THandle {handle = h, rcvKey, blockSize} = + B.hGet h blockSize >>= decryptBlock rcvKey >>= \case + Left _ -> pure $ Left TEDecrypt + Right "" -> ioe_EOF + Right msg -> pure $ Right msg + +encryptBlock :: SessionKey -> Int -> ByteString -> IO (Either C.CryptoError (AuthTag, ByteString)) +encryptBlock k@SessionKey {aesKey} size block = do + ivBytes <- makeNextIV k + runExceptT $ C.encryptAES aesKey ivBytes size block + +decryptBlock :: SessionKey -> ByteString -> IO (Either C.CryptoError ByteString) +decryptBlock k@SessionKey {aesKey} block = do + let (authTag, msg') = B.splitAt C.authTagSize block + ivBytes <- makeNextIV k + runExceptT $ C.decryptAES aesKey ivBytes msg' (C.bsToAuthTag authTag) + +makeNextIV :: SessionKey -> IO C.IV +makeNextIV SessionKey {baseIV, counter} = atomically $ do + c <- readTVar counter + writeTVar counter $ c + 1 + pure $ iv c + where + (start, rest) = B.splitAt 4 $ C.unIV baseIV + iv c = C.IV $ (start `xor` encodeWord32 c) <> rest + +-- | Server SMP encrypted transport handshake. +-- +-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a +-- +-- The numbers in function names refer to the steps in the document. +serverHandshake :: Handle -> C.FullKeyPair -> ExceptT TransportError IO THandle +serverHandshake h (k, pk) = do + liftIO sendHeaderAndPublicKey_1 + encryptedKeys <- receiveEncryptedKeys_4 + -- TODO server currently ignores blockSize returned by the client + -- this is reserved for future support of streams + ClientHandshake {blockSize = _, sndKey, rcvKey} <- decryptParseKeys_5 encryptedKeys + th <- liftIO $ transportHandle h rcvKey sndKey transportBlockSize -- keys are swapped here + sendWelcome_6 th + pure th + where + sendHeaderAndPublicKey_1 :: IO () + sendHeaderAndPublicKey_1 = do + let sKey = C.encodePubKey k + header = ServerHeader {blockSize = transportBlockSize, keySize = B.length sKey} + B.hPut h $ binaryServerHeader header <> sKey + receiveEncryptedKeys_4 :: ExceptT TransportError IO ByteString + receiveEncryptedKeys_4 = + liftIO (B.hGet h $ C.publicKeySize k) >>= \case + "" -> throwE $ TEHandshake TERMINATED + ks -> pure ks + decryptParseKeys_5 :: ByteString -> ExceptT TransportError IO ClientHandshake + decryptParseKeys_5 encKeys = + liftError (const $ TEHandshake DECRYPT) (C.decryptOAEP pk encKeys) + >>= liftEither . parseClientHandshake + sendWelcome_6 :: THandle -> ExceptT TransportError IO () + sendWelcome_6 th = ExceptT . tPutEncrypted th $ serializeSMPVersion currentSMPVersion <> " " + +-- | Client SMP encrypted transport handshake. +-- +-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a +-- +-- The numbers in function names refer to the steps in the document. +clientHandshake :: Handle -> Maybe C.KeyHash -> ExceptT TransportError IO THandle +clientHandshake h keyHash = do + (k, blkSize) <- getHeaderAndPublicKey_1_2 + -- TODO currently client always uses the blkSize returned by the server + keys@ClientHandshake {sndKey, rcvKey} <- liftIO $ generateKeys_3 blkSize + sendEncryptedKeys_4 k keys + th <- liftIO $ transportHandle h sndKey rcvKey blkSize + getWelcome_6 th >>= checkVersion + pure th + where + getHeaderAndPublicKey_1_2 :: ExceptT TransportError IO (C.PublicKey, Int) + getHeaderAndPublicKey_1_2 = do + header <- liftIO (B.hGet h serverHeaderSize) + ServerHeader {blockSize, keySize} <- liftEither $ parse serverHeaderP (TEHandshake HEADER) header + when (blockSize < transportBlockSize || blockSize > maxTransportBlockSize) $ + throwError $ TEHandshake HEADER + s <- liftIO $ B.hGet h keySize + maybe (pure ()) (validateKeyHash_2 s) keyHash + key <- liftEither $ parseKey s + pure (key, blockSize) + parseKey :: ByteString -> Either TransportError C.PublicKey + parseKey = first (const $ TEHandshake RSA_KEY) . parseAll C.binaryPubKeyP + validateKeyHash_2 :: ByteString -> C.KeyHash -> ExceptT TransportError IO () + validateKeyHash_2 k (C.KeyHash kHash) + | C.sha256Hash k == kHash = pure () + | otherwise = throwE $ TEHandshake BAD_HASH + generateKeys_3 :: Int -> IO ClientHandshake + generateKeys_3 blkSize = ClientHandshake blkSize <$> generateKey <*> generateKey + generateKey :: IO SessionKey + generateKey = do + aesKey <- C.randomAesKey + baseIV <- C.randomIV + pure SessionKey {aesKey, baseIV, counter = undefined} + sendEncryptedKeys_4 :: C.PublicKey -> ClientHandshake -> ExceptT TransportError IO () + sendEncryptedKeys_4 k keys = + liftError (const $ TEHandshake ENCRYPT) (C.encryptOAEP k $ serializeClientHandshake keys) + >>= liftIO . B.hPut h + getWelcome_6 :: THandle -> ExceptT TransportError IO SMPVersion + getWelcome_6 th = ExceptT $ (>>= parseSMPVersion) <$> tGetEncrypted th + parseSMPVersion :: ByteString -> Either TransportError SMPVersion + parseSMPVersion = first (const $ TEHandshake VERSION) . A.parseOnly (smpVersionP <* A.space) + checkVersion :: SMPVersion -> ExceptT TransportError IO () + checkVersion smpVersion = + when (major smpVersion > major currentSMPVersion) . throwE $ + TEHandshake MAJOR_VERSION + +data ServerHeader = ServerHeader {blockSize :: Int, keySize :: Int} + deriving (Eq, Show) + +binaryRsaTransport :: Int +binaryRsaTransport = 0 + +transportBlockSize :: Int +transportBlockSize = 4096 + +maxTransportBlockSize :: Int +maxTransportBlockSize = 65536 + +serverHeaderSize :: Int +serverHeaderSize = 8 + +binaryServerHeader :: ServerHeader -> ByteString +binaryServerHeader ServerHeader {blockSize, keySize} = + encodeEnum32 blockSize <> encodeEnum16 binaryRsaTransport <> encodeEnum16 keySize + +serverHeaderP :: Parser ServerHeader +serverHeaderP = ServerHeader <$> int32 <* binaryRsaTransportP <*> int16 + +serializeClientHandshake :: ClientHandshake -> ByteString +serializeClientHandshake ClientHandshake {blockSize, sndKey, rcvKey} = + encodeEnum32 blockSize <> encodeEnum16 binaryRsaTransport <> serializeKey sndKey <> serializeKey rcvKey + where + serializeKey :: SessionKey -> ByteString + serializeKey SessionKey {aesKey, baseIV} = C.unKey aesKey <> C.unIV baseIV + +clientHandshakeP :: Parser ClientHandshake +clientHandshakeP = ClientHandshake <$> int32 <* binaryRsaTransportP <*> keyP <*> keyP + where + keyP :: Parser SessionKey + keyP = do + aesKey <- C.aesKeyP + baseIV <- C.ivP + pure SessionKey {aesKey, baseIV, counter = undefined} + +int32 :: Parser Int +int32 = decodeNum32 <$> A.take 4 + +int16 :: Parser Int +int16 = decodeNum16 <$> A.take 2 + +binaryRsaTransportP :: Parser () +binaryRsaTransportP = binaryRsa =<< int16 + where + binaryRsa :: Int -> Parser () + binaryRsa n + | n == binaryRsaTransport = pure () + | otherwise = fail "unknown transport mode" + +parseClientHandshake :: ByteString -> Either TransportError ClientHandshake +parseClientHandshake = parse clientHandshakeP $ TEHandshake AES_KEYS + +transportHandle :: Handle -> SessionKey -> SessionKey -> Int -> IO THandle +transportHandle h sk rk blockSize = do + sndCounter <- newTVarIO 0 + rcvCounter <- newTVarIO 0 + pure + THandle + { handle = h, + sndKey = sk {counter = sndCounter}, + rcvKey = rk {counter = rcvCounter}, + blockSize + } diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs new file mode 100644 --- /dev/null +++ b/src/Simplex/Messaging/Util.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Simplex.Messaging.Util where + +import Control.Monad.Except +import Control.Monad.IO.Unlift +import Data.Bifunctor (first) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import UnliftIO.Async +import UnliftIO.Exception (Exception) +import qualified UnliftIO.Exception as E + +newtype InternalException e = InternalException {unInternalException :: e} + deriving (Eq, Show) + +instance Exception e => Exception (InternalException e) + +instance (MonadUnliftIO m, Exception e) => MonadUnliftIO (ExceptT e m) where + withRunInIO :: ((forall a. ExceptT e m a -> IO a) -> IO b) -> ExceptT e m b + withRunInIO exceptToIO = + withExceptT unInternalException . ExceptT . E.try $ + withRunInIO $ \run -> + exceptToIO $ run . (either (E.throwIO . InternalException) return <=< runExceptT) + +raceAny_ :: MonadUnliftIO m => [m a] -> m () +raceAny_ = r [] + where + r as (m : ms) = withAsync m $ \a -> r (a : as) ms + r as [] = void $ waitAnyCancel as + +infixl 4 <$$>, <$?> + +(<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) +(<$$>) = fmap . fmap + +(<$?>) :: MonadFail m => (a -> Either String b) -> m a -> m b +f <$?> m = m >>= either fail pure . f + +bshow :: Show a => a -> ByteString +bshow = B.pack . show + +liftIOEither :: (MonadIO m, MonadError e m) => IO (Either e a) -> m a +liftIOEither a = liftIO a >>= liftEither + +liftError :: (MonadIO m, MonadError e' m) => (e -> e') -> ExceptT e IO a -> m a +liftError f = liftEitherError f . runExceptT + +liftEitherError :: (MonadIO m, MonadError e' m) => (e -> e') -> IO (Either e a) -> m a +liftEitherError f a = liftIOEither (first f <$> a) diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs new file mode 100644 --- /dev/null +++ b/tests/AgentTests.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +module AgentTests where + +import AgentTests.SQLiteTests (storeStressTest, storeTests) +import Control.Concurrent +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import SMPAgentClient +import Simplex.Messaging.Agent.Protocol +import Simplex.Messaging.Protocol (ErrorType (..), MsgBody) +import System.IO (Handle) +import System.Timeout +import Test.Hspec + +agentTests :: Spec +agentTests = do + describe "SQLite store" do + storeTests + storeStressTest + describe "SMP agent protocol syntax" syntaxTests + describe "Establishing duplex connection" do + it "should connect via one server and one agent" $ + smpAgentTest2_1_1 testDuplexConnection + it "should connect via one server and 2 agents" $ + smpAgentTest2_2_1 testDuplexConnection + it "should connect via 2 servers and 2 agents" $ + smpAgentTest2_2_2 testDuplexConnection + describe "Connection subscriptions" do + it "should connect via one server and one agent" $ + smpAgentTest3_1_1 testSubscription + it "should send notifications to client when server disconnects" $ + smpAgentServerTest testSubscrNotification + +-- | simple test for one command with the expected response +(>#>) :: ARawTransmission -> ARawTransmission -> Expectation +command >#> response = smpAgentTest command `shouldReturn` response + +-- | simple test for one command with a predicate for the expected response +(>#>=) :: ARawTransmission -> ((ByteString, ByteString, [ByteString]) -> Bool) -> Expectation +command >#>= p = smpAgentTest command >>= (`shouldSatisfy` p . \(cId, cAlias, cmd) -> (cId, cAlias, B.words cmd)) + +-- | send transmission `t` to handle `h` and get response +(#:) :: Handle -> (ByteString, ByteString, ByteString) -> IO (ATransmissionOrError 'Agent) +h #: t = tPutRaw h t >> tGet SAgent h + +-- | action and expected response +-- `h #:t #> r` is the test that sends `t` to `h` and validates that the response is `r` +(#>) :: IO (ATransmissionOrError 'Agent) -> ATransmission 'Agent -> Expectation +action #> (corrId, cAlias, cmd) = action `shouldReturn` (corrId, cAlias, Right cmd) + +-- | action and predicate for the response +-- `h #:t =#> p` is the test that sends `t` to `h` and validates the response using `p` +(=#>) :: IO (ATransmissionOrError 'Agent) -> (ATransmission 'Agent -> Bool) -> Expectation +action =#> p = action >>= (`shouldSatisfy` p . correctTransmission) + +correctTransmission :: ATransmissionOrError a -> ATransmission a +correctTransmission (corrId, cAlias, cmdOrErr) = case cmdOrErr of + Right cmd -> (corrId, cAlias, cmd) + Left e -> error $ show e + +-- | receive message to handle `h` and validate that it is the expected one +(<#) :: Handle -> ATransmission 'Agent -> Expectation +h <# (corrId, cAlias, cmd) = tGet SAgent h `shouldReturn` (corrId, cAlias, Right cmd) + +-- | receive message to handle `h` and validate it using predicate `p` +(<#=) :: Handle -> (ATransmission 'Agent -> Bool) -> Expectation +h <#= p = tGet SAgent h >>= (`shouldSatisfy` p . correctTransmission) + +-- | test that nothing is delivered to handle `h` during 10ms +(#:#) :: Handle -> String -> Expectation +h #:# err = tryGet `shouldReturn` () + where + tryGet = + 10000 `timeout` tGet SAgent h >>= \case + Just _ -> error err + _ -> return () + +pattern Msg :: MsgBody -> ACommand 'Agent +pattern Msg msgBody <- MSG {msgBody, msgIntegrity = MsgOk} + +testDuplexConnection :: Handle -> Handle -> IO () +testDuplexConnection alice bob = do + ("1", "bob", Right (INV qInfo)) <- alice #: ("1", "bob", "NEW") + let qInfo' = serializeSmpQueueInfo qInfo + bob #: ("11", "alice", "JOIN " <> qInfo') #> ("", "alice", CON) + alice <# ("", "bob", CON) + alice #: ("2", "bob", "SEND :hello") =#> \case ("2", "bob", SENT 1) -> True; _ -> False + alice #: ("3", "bob", "SEND :how are you?") =#> \case ("3", "bob", SENT 2) -> True; _ -> False + bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False + bob <#= \case ("", "alice", Msg "how are you?") -> True; _ -> False + bob #: ("14", "alice", "SEND 9\nhello too") =#> \case ("14", "alice", SENT 3) -> True; _ -> False + alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False + bob #: ("15", "alice", "SEND 9\nmessage 1") =#> \case ("15", "alice", SENT 4) -> True; _ -> False + alice <#= \case ("", "bob", Msg "message 1") -> True; _ -> False + alice #: ("5", "bob", "OFF") #> ("5", "bob", OK) + bob #: ("17", "alice", "SEND 9\nmessage 3") #> ("17", "alice", ERR (SMP AUTH)) + alice #: ("6", "bob", "DEL") #> ("6", "bob", OK) + alice #:# "nothing else should be delivered to alice" + +testSubscription :: Handle -> Handle -> Handle -> IO () +testSubscription alice1 alice2 bob = do + ("1", "bob", Right (INV qInfo)) <- alice1 #: ("1", "bob", "NEW") + let qInfo' = serializeSmpQueueInfo qInfo + bob #: ("11", "alice", "JOIN " <> qInfo') #> ("", "alice", CON) + bob #: ("12", "alice", "SEND 5\nhello") =#> \case ("12", "alice", SENT _) -> True; _ -> False + bob #: ("13", "alice", "SEND 11\nhello again") =#> \case ("13", "alice", SENT _) -> True; _ -> False + alice1 <# ("", "bob", CON) + alice1 <#= \case ("", "bob", Msg "hello") -> True; _ -> False + alice1 <#= \case ("", "bob", Msg "hello again") -> True; _ -> False + alice2 #: ("21", "bob", "SUB") #> ("21", "bob", OK) + alice1 <# ("", "bob", END) + bob #: ("14", "alice", "SEND 2\nhi") =#> \case ("14", "alice", SENT _) -> True; _ -> False + alice2 <#= \case ("", "bob", Msg "hi") -> True; _ -> False + alice1 #:# "nothing else should be delivered to alice1" + +testSubscrNotification :: (ThreadId, ThreadId) -> Handle -> IO () +testSubscrNotification (server, _) client = do + client #: ("1", "conn1", "NEW") =#> \case ("1", "conn1", INV _) -> True; _ -> False + client #:# "nothing should be delivered to client before the server is killed" + killThread server + client <# ("", "conn1", END) + +samplePublicKey :: ByteString +samplePublicKey = "rsa:MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAtn1NI2tPoOGSGfad0aUg0tJ0kG2nzrIPGLiz8wb3dQSJC9xkRHyzHhEE8Kmy2cM4q7rNZIlLcm4M7oXOTe7SC4x59bLQG9bteZPKqXu9wk41hNamV25PWQ4zIcIRmZKETVGbwN7jFMpH7wxLdI1zzMArAPKXCDCJ5ctWh4OWDI6OR6AcCtEj+toCI6N6pjxxn5VigJtwiKhxYpoUJSdNM60wVEDCSUrZYBAuDH8pOxPfP+Tm4sokaFDTIG3QJFzOjC+/9nW4MUjAOFll9PCp9kaEFHJ/YmOYKMWNOCCPvLS6lxA83i0UaardkNLNoFS5paWfTlroxRwOC2T6PwO2ywKBgDjtXcSED61zK1seocQMyGRINnlWdhceD669kIHju/f6kAayvYKW3/lbJNXCmyinAccBosO08/0sUxvtuniIo18kfYJE0UmP1ReCjhMP+O+yOmwZJini/QelJk/Pez8IIDDWnY1qYQsN/q7ocjakOYrpGG7mig6JMFpDJtD6istR" + +syntaxTests :: Spec +syntaxTests = do + it "unknown command" $ ("1", "5678", "HELLO") >#> ("1", "5678", "ERR CMD SYNTAX") + describe "NEW" do + describe "valid" do + -- TODO: ERROR no connection alias in the response (it does not generate it yet if not provided) + -- TODO: add tests with defined connection alias + xit "without parameters" $ ("211", "", "NEW") >#>= \case ("211", "", "INV" : _) -> True; _ -> False + describe "invalid" do + -- TODO: add tests with defined connection alias + it "with parameters" $ ("222", "", "NEW hi") >#> ("222", "", "ERR CMD SYNTAX") + + describe "JOIN" do + describe "valid" do + -- TODO: ERROR no connection alias in the response (it does not generate it yet if not provided) + -- TODO: add tests with defined connection alias + it "using same server as in invitation" $ + ("311", "", "JOIN smp::localhost:5000::1234::" <> samplePublicKey) >#> ("311", "", "ERR SMP AUTH") + describe "invalid" do + -- TODO: JOIN is not merged yet - to be added + it "no parameters" $ ("321", "", "JOIN") >#> ("321", "", "ERR CMD SYNTAX") diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs new file mode 100644 --- /dev/null +++ b/tests/AgentTests/SQLiteTests.hs @@ -0,0 +1,412 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} + +module AgentTests.SQLiteTests (storeTests, storeStressTest) where + +import Control.Concurrent.Async (concurrently_) +import Control.Monad (replicateM_) +import Control.Monad.Except (ExceptT, runExceptT) +import qualified Crypto.PubKey.RSA as R +import Data.ByteString.Char8 (ByteString) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Time +import Data.Word (Word32) +import qualified Database.SQLite.Simple as DB +import Database.SQLite.Simple.QQ (sql) +import SMPClient (testKeyHash) +import Simplex.Messaging.Agent.Protocol +import Simplex.Messaging.Agent.Store +import Simplex.Messaging.Agent.Store.SQLite +import qualified Simplex.Messaging.Crypto as C +import System.Random (Random (randomIO)) +import Test.Hspec +import UnliftIO.Directory (removeFile) + +testDB :: String +testDB = "tests/tmp/smp-agent.test.db" + +withStore :: SpecWith SQLiteStore -> Spec +withStore = before createStore . after removeStore + +withStore2 :: SpecWith (SQLiteStore, SQLiteStore) -> Spec +withStore2 = before connect2 . after (removeStore . fst) + where + connect2 :: IO (SQLiteStore, SQLiteStore) + connect2 = do + s1 <- createStore + s2 <- connectSQLiteStore $ dbFilePath s1 + pure (s1, s2) + +createStore :: IO SQLiteStore +createStore = do + -- Randomize DB file name to avoid SQLite IO errors supposedly caused by asynchronous + -- IO operations on multiple similarly named files; error seems to be environment specific + r <- randomIO :: IO Word32 + createSQLiteStore $ testDB <> show r + +removeStore :: SQLiteStore -> IO () +removeStore store = do + DB.close $ dbConn store + removeFile $ dbFilePath store + +returnsResult :: (Eq a, Eq e, Show a, Show e) => ExceptT e IO a -> a -> Expectation +action `returnsResult` r = runExceptT action `shouldReturn` Right r + +throwsError :: (Eq a, Eq e, Show a, Show e) => ExceptT e IO a -> e -> Expectation +action `throwsError` e = runExceptT action `shouldReturn` Left e + +-- TODO add null port tests +storeTests :: Spec +storeTests = withStore do + describe "store setup" do + testCompiledThreadsafe + testForeignKeysEnabled + describe "store methods" do + describe "Queue and Connection management" do + describe "createRcvConn" do + testCreateRcvConn + testCreateRcvConnDuplicate + describe "createSndConn" do + testCreateSndConn + testCreateSndConnDuplicate + describe "getAllConnAliases" testGetAllConnAliases + describe "getRcvConn" testGetRcvConn + describe "deleteConn" do + testDeleteRcvConn + testDeleteSndConn + testDeleteDuplexConn + describe "upgradeRcvConnToDuplex" do + testUpgradeRcvConnToDuplex + describe "upgradeSndConnToDuplex" do + testUpgradeSndConnToDuplex + describe "set Queue status" do + describe "setRcvQueueStatus" do + testSetRcvQueueStatus + testSetRcvQueueStatusNoQueue + describe "setSndQueueStatus" do + testSetSndQueueStatus + testSetSndQueueStatusNoQueue + testSetQueueStatusDuplex + describe "Msg management" do + describe "create Msg" do + testCreateRcvMsg + testCreateSndMsg + testCreateRcvAndSndMsgs + +storeStressTest :: Spec +storeStressTest = withStore2 $ + it "should pass stress test on multiple concurrent write transactions" $ \(s1, s2) -> do + _ <- runExceptT $ createRcvConn s1 rcvQueue1 + concurrently_ (runTest s1) (runTest s2) + where + runTest :: SQLiteStore -> IO (Either StoreError ()) + runTest store = runExceptT . replicateM_ 100 $ do + (internalId, internalRcvId, _, _) <- updateRcvIds store rcvQueue1 + let rcvMsgData = mkRcvMsgData internalId internalRcvId 0 "0" "hash_dummy" + createRcvMsg store rcvQueue1 rcvMsgData + +testCompiledThreadsafe :: SpecWith SQLiteStore +testCompiledThreadsafe = do + it "compiled sqlite library should be threadsafe" $ \store -> do + compileOptions <- DB.query_ (dbConn store) "pragma COMPILE_OPTIONS;" :: IO [[T.Text]] + compileOptions `shouldNotContain` [["THREADSAFE=0"]] + +testForeignKeysEnabled :: SpecWith SQLiteStore +testForeignKeysEnabled = do + it "foreign keys should be enabled" $ \store -> do + let inconsistentQuery = + [sql| + INSERT INTO connections + (conn_alias, rcv_host, rcv_port, rcv_id, snd_host, snd_port, snd_id) + VALUES + ("conn1", "smp.simplex.im", "5223", "1234", "smp.simplex.im", "5223", "2345"); + |] + DB.execute_ (dbConn store) inconsistentQuery + `shouldThrow` (\e -> DB.sqlError e == DB.ErrorConstraint) + +rcvQueue1 :: RcvQueue +rcvQueue1 = + RcvQueue + { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash, + rcvId = "1234", + connAlias = "conn1", + rcvPrivateKey = C.safePrivateKey (1, 2, 3), + sndId = Just "2345", + sndKey = Nothing, + decryptKey = C.safePrivateKey (1, 2, 3), + verifyKey = Nothing, + status = New + } + +sndQueue1 :: SndQueue +sndQueue1 = + SndQueue + { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash, + sndId = "3456", + connAlias = "conn1", + sndPrivateKey = C.safePrivateKey (1, 2, 3), + encryptKey = C.PublicKey $ R.PublicKey 1 2 3, + signKey = C.safePrivateKey (1, 2, 3), + status = New + } + +testCreateRcvConn :: SpecWith SQLiteStore +testCreateRcvConn = do + it "should create RcvConnection and add SndQueue" $ \store -> do + createRcvConn store rcvQueue1 + `returnsResult` () + getConn store "conn1" + `returnsResult` SomeConn SCRcv (RcvConnection "conn1" rcvQueue1) + upgradeRcvConnToDuplex store "conn1" sndQueue1 + `returnsResult` () + getConn store "conn1" + `returnsResult` SomeConn SCDuplex (DuplexConnection "conn1" rcvQueue1 sndQueue1) + +testCreateRcvConnDuplicate :: SpecWith SQLiteStore +testCreateRcvConnDuplicate = do + it "should throw error on attempt to create duplicate RcvConnection" $ \store -> do + _ <- runExceptT $ createRcvConn store rcvQueue1 + createRcvConn store rcvQueue1 + `throwsError` SEConnDuplicate + +testCreateSndConn :: SpecWith SQLiteStore +testCreateSndConn = do + it "should create SndConnection and add RcvQueue" $ \store -> do + createSndConn store sndQueue1 + `returnsResult` () + getConn store "conn1" + `returnsResult` SomeConn SCSnd (SndConnection "conn1" sndQueue1) + upgradeSndConnToDuplex store "conn1" rcvQueue1 + `returnsResult` () + getConn store "conn1" + `returnsResult` SomeConn SCDuplex (DuplexConnection "conn1" rcvQueue1 sndQueue1) + +testCreateSndConnDuplicate :: SpecWith SQLiteStore +testCreateSndConnDuplicate = do + it "should throw error on attempt to create duplicate SndConnection" $ \store -> do + _ <- runExceptT $ createSndConn store sndQueue1 + createSndConn store sndQueue1 + `throwsError` SEConnDuplicate + +testGetAllConnAliases :: SpecWith SQLiteStore +testGetAllConnAliases = do + it "should get all conn aliases" $ \store -> do + _ <- runExceptT $ createRcvConn store rcvQueue1 + _ <- runExceptT $ createSndConn store sndQueue1 {connAlias = "conn2"} + getAllConnAliases store + `returnsResult` ["conn1" :: ConnAlias, "conn2" :: ConnAlias] + +testGetRcvConn :: SpecWith SQLiteStore +testGetRcvConn = do + it "should get connection using rcv queue id and server" $ \store -> do + let smpServer = SMPServer "smp.simplex.im" (Just "5223") testKeyHash + let recipientId = "1234" + _ <- runExceptT $ createRcvConn store rcvQueue1 + getRcvConn store smpServer recipientId + `returnsResult` SomeConn SCRcv (RcvConnection (connAlias (rcvQueue1 :: RcvQueue)) rcvQueue1) + +testDeleteRcvConn :: SpecWith SQLiteStore +testDeleteRcvConn = do + it "should create RcvConnection and delete it" $ \store -> do + _ <- runExceptT $ createRcvConn store rcvQueue1 + getConn store "conn1" + `returnsResult` SomeConn SCRcv (RcvConnection "conn1" rcvQueue1) + deleteConn store "conn1" + `returnsResult` () + -- TODO check queues are deleted as well + getConn store "conn1" + `throwsError` SEConnNotFound + +testDeleteSndConn :: SpecWith SQLiteStore +testDeleteSndConn = do + it "should create SndConnection and delete it" $ \store -> do + _ <- runExceptT $ createSndConn store sndQueue1 + getConn store "conn1" + `returnsResult` SomeConn SCSnd (SndConnection "conn1" sndQueue1) + deleteConn store "conn1" + `returnsResult` () + -- TODO check queues are deleted as well + getConn store "conn1" + `throwsError` SEConnNotFound + +testDeleteDuplexConn :: SpecWith SQLiteStore +testDeleteDuplexConn = do + it "should create DuplexConnection and delete it" $ \store -> do + _ <- runExceptT $ createRcvConn store rcvQueue1 + _ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1 + getConn store "conn1" + `returnsResult` SomeConn SCDuplex (DuplexConnection "conn1" rcvQueue1 sndQueue1) + deleteConn store "conn1" + `returnsResult` () + -- TODO check queues are deleted as well + getConn store "conn1" + `throwsError` SEConnNotFound + +testUpgradeRcvConnToDuplex :: SpecWith SQLiteStore +testUpgradeRcvConnToDuplex = do + it "should throw error on attempt to add SndQueue to SndConnection or DuplexConnection" $ \store -> do + _ <- runExceptT $ createSndConn store sndQueue1 + let anotherSndQueue = + SndQueue + { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash, + sndId = "2345", + connAlias = "conn1", + sndPrivateKey = C.safePrivateKey (1, 2, 3), + encryptKey = C.PublicKey $ R.PublicKey 1 2 3, + signKey = C.safePrivateKey (1, 2, 3), + status = New + } + upgradeRcvConnToDuplex store "conn1" anotherSndQueue + `throwsError` SEBadConnType CSnd + _ <- runExceptT $ upgradeSndConnToDuplex store "conn1" rcvQueue1 + upgradeRcvConnToDuplex store "conn1" anotherSndQueue + `throwsError` SEBadConnType CDuplex + +testUpgradeSndConnToDuplex :: SpecWith SQLiteStore +testUpgradeSndConnToDuplex = do + it "should throw error on attempt to add RcvQueue to RcvConnection or DuplexConnection" $ \store -> do + _ <- runExceptT $ createRcvConn store rcvQueue1 + let anotherRcvQueue = + RcvQueue + { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash, + rcvId = "3456", + connAlias = "conn1", + rcvPrivateKey = C.safePrivateKey (1, 2, 3), + sndId = Just "4567", + sndKey = Nothing, + decryptKey = C.safePrivateKey (1, 2, 3), + verifyKey = Nothing, + status = New + } + upgradeSndConnToDuplex store "conn1" anotherRcvQueue + `throwsError` SEBadConnType CRcv + _ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1 + upgradeSndConnToDuplex store "conn1" anotherRcvQueue + `throwsError` SEBadConnType CDuplex + +testSetRcvQueueStatus :: SpecWith SQLiteStore +testSetRcvQueueStatus = do + it "should update status of RcvQueue" $ \store -> do + _ <- runExceptT $ createRcvConn store rcvQueue1 + getConn store "conn1" + `returnsResult` SomeConn SCRcv (RcvConnection "conn1" rcvQueue1) + setRcvQueueStatus store rcvQueue1 Confirmed + `returnsResult` () + getConn store "conn1" + `returnsResult` SomeConn SCRcv (RcvConnection "conn1" rcvQueue1 {status = Confirmed}) + +testSetSndQueueStatus :: SpecWith SQLiteStore +testSetSndQueueStatus = do + it "should update status of SndQueue" $ \store -> do + _ <- runExceptT $ createSndConn store sndQueue1 + getConn store "conn1" + `returnsResult` SomeConn SCSnd (SndConnection "conn1" sndQueue1) + setSndQueueStatus store sndQueue1 Confirmed + `returnsResult` () + getConn store "conn1" + `returnsResult` SomeConn SCSnd (SndConnection "conn1" sndQueue1 {status = Confirmed}) + +testSetQueueStatusDuplex :: SpecWith SQLiteStore +testSetQueueStatusDuplex = do + it "should update statuses of RcvQueue and SndQueue in DuplexConnection" $ \store -> do + _ <- runExceptT $ createRcvConn store rcvQueue1 + _ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1 + getConn store "conn1" + `returnsResult` SomeConn SCDuplex (DuplexConnection "conn1" rcvQueue1 sndQueue1) + setRcvQueueStatus store rcvQueue1 Secured + `returnsResult` () + getConn store "conn1" + `returnsResult` SomeConn SCDuplex (DuplexConnection "conn1" rcvQueue1 {status = Secured} sndQueue1) + setSndQueueStatus store sndQueue1 Confirmed + `returnsResult` () + getConn store "conn1" + `returnsResult` SomeConn SCDuplex (DuplexConnection "conn1" rcvQueue1 {status = Secured} sndQueue1 {status = Confirmed}) + +testSetRcvQueueStatusNoQueue :: SpecWith SQLiteStore +testSetRcvQueueStatusNoQueue = do + xit "should throw error on attempt to update status of non-existent RcvQueue" $ \store -> do + setRcvQueueStatus store rcvQueue1 Confirmed + `throwsError` SEConnNotFound + +testSetSndQueueStatusNoQueue :: SpecWith SQLiteStore +testSetSndQueueStatusNoQueue = do + xit "should throw error on attempt to update status of non-existent SndQueue" $ \store -> do + setSndQueueStatus store sndQueue1 Confirmed + `throwsError` SEConnNotFound + +hw :: ByteString +hw = encodeUtf8 "Hello world!" + +ts :: UTCTime +ts = UTCTime (fromGregorian 2021 02 24) (secondsToDiffTime 0) + +mkRcvMsgData :: InternalId -> InternalRcvId -> ExternalSndId -> BrokerId -> MsgHash -> RcvMsgData +mkRcvMsgData internalId internalRcvId externalSndId brokerId internalHash = + RcvMsgData + { internalId, + internalRcvId, + internalTs = ts, + senderMeta = (externalSndId, ts), + brokerMeta = (brokerId, ts), + msgBody = hw, + internalHash, + externalPrevSndHash = "hash_from_sender", + msgIntegrity = MsgOk + } + +testCreateRcvMsg' :: SQLiteStore -> PrevExternalSndId -> PrevRcvMsgHash -> RcvQueue -> RcvMsgData -> Expectation +testCreateRcvMsg' store expectedPrevSndId expectedPrevHash rcvQueue rcvMsgData@RcvMsgData {..} = do + updateRcvIds store rcvQueue + `returnsResult` (internalId, internalRcvId, expectedPrevSndId, expectedPrevHash) + createRcvMsg store rcvQueue rcvMsgData + `returnsResult` () + +testCreateRcvMsg :: SpecWith SQLiteStore +testCreateRcvMsg = do + it "should reserve internal ids and create a RcvMsg" $ \store -> do + _ <- runExceptT $ createRcvConn store rcvQueue1 + -- TODO getMsg to check message + testCreateRcvMsg' store 0 "" rcvQueue1 $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "hash_dummy" + testCreateRcvMsg' store 1 "hash_dummy" rcvQueue1 $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "new_hash_dummy" + +mkSndMsgData :: InternalId -> InternalSndId -> MsgHash -> SndMsgData +mkSndMsgData internalId internalSndId internalHash = + SndMsgData + { internalId, + internalSndId, + internalTs = ts, + msgBody = hw, + internalHash + } + +testCreateSndMsg' :: SQLiteStore -> PrevSndMsgHash -> SndQueue -> SndMsgData -> Expectation +testCreateSndMsg' store expectedPrevHash sndQueue sndMsgData@SndMsgData {..} = do + updateSndIds store sndQueue + `returnsResult` (internalId, internalSndId, expectedPrevHash) + createSndMsg store sndQueue sndMsgData + `returnsResult` () + +testCreateSndMsg :: SpecWith SQLiteStore +testCreateSndMsg = do + it "should create a SndMsg and return InternalId and PrevSndMsgHash" $ \store -> do + _ <- runExceptT $ createSndConn store sndQueue1 + -- TODO getMsg to check message + testCreateSndMsg' store "" sndQueue1 $ mkSndMsgData (InternalId 1) (InternalSndId 1) "hash_dummy" + testCreateSndMsg' store "hash_dummy" sndQueue1 $ mkSndMsgData (InternalId 2) (InternalSndId 2) "new_hash_dummy" + +testCreateRcvAndSndMsgs :: SpecWith SQLiteStore +testCreateRcvAndSndMsgs = do + it "should create multiple RcvMsg and SndMsg, correctly ordering internal Ids and returning previous state" $ \store -> do + _ <- runExceptT $ createRcvConn store rcvQueue1 + _ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1 + testCreateRcvMsg' store 0 "" rcvQueue1 $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "rcv_hash_1" + testCreateRcvMsg' store 1 "rcv_hash_1" rcvQueue1 $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "rcv_hash_2" + testCreateSndMsg' store "" sndQueue1 $ mkSndMsgData (InternalId 3) (InternalSndId 1) "snd_hash_1" + testCreateRcvMsg' store 2 "rcv_hash_2" rcvQueue1 $ mkRcvMsgData (InternalId 4) (InternalRcvId 3) 3 "3" "rcv_hash_3" + testCreateSndMsg' store "snd_hash_1" sndQueue1 $ mkSndMsgData (InternalId 5) (InternalSndId 2) "snd_hash_2" + testCreateSndMsg' store "snd_hash_2" sndQueue1 $ mkSndMsgData (InternalId 6) (InternalSndId 3) "snd_hash_3" diff --git a/tests/ProtocolErrorTests.hs b/tests/ProtocolErrorTests.hs new file mode 100644 --- /dev/null +++ b/tests/ProtocolErrorTests.hs @@ -0,0 +1,18 @@ +module ProtocolErrorTests where + +import Simplex.Messaging.Agent.Protocol (AgentErrorType, agentErrorTypeP, serializeAgentError) +import Simplex.Messaging.Parsers (parseAll) +import Simplex.Messaging.Protocol (ErrorType, errorTypeP, serializeErrorType) +import Test.Hspec +import Test.Hspec.QuickCheck (modifyMaxSuccess) +import Test.QuickCheck + +protocolErrorTests :: Spec +protocolErrorTests = modifyMaxSuccess (const 1000) $ do + describe "errors parsing / serializing" $ do + it "should parse SMP protocol errors" . property $ \err -> + parseAll errorTypeP (serializeErrorType err) + == Right (err :: ErrorType) + it "should parse SMP agent errors" . property $ \err -> + parseAll agentErrorTypeP (serializeAgentError err) + == Right (err :: AgentErrorType) diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs new file mode 100644 --- /dev/null +++ b/tests/SMPAgentClient.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module SMPAgentClient where + +import Control.Monad.IO.Unlift +import Crypto.Random +import qualified Data.ByteString.Char8 as B +import qualified Data.List.NonEmpty as L +import Network.Socket (HostName, ServiceName) +import SMPClient + ( serverBracket, + testKeyHash, + testPort, + testPort2, + withSmpServer, + withSmpServerOn, + withSmpServerThreadOn, + ) +import Simplex.Messaging.Agent (runSMPAgentBlocking) +import Simplex.Messaging.Agent.Env.SQLite +import Simplex.Messaging.Agent.Protocol +import Simplex.Messaging.Client (SMPClientConfig (..), smpDefaultConfig) +import Simplex.Messaging.Transport +import Test.Hspec +import UnliftIO.Concurrent +import UnliftIO.Directory +import UnliftIO.IO + +agentTestHost :: HostName +agentTestHost = "localhost" + +agentTestPort :: ServiceName +agentTestPort = "5010" + +agentTestPort2 :: ServiceName +agentTestPort2 = "5011" + +agentTestPort3 :: ServiceName +agentTestPort3 = "5012" + +testDB :: String +testDB = "tests/tmp/smp-agent.test.protocol.db" + +testDB2 :: String +testDB2 = "tests/tmp/smp-agent2.test.protocol.db" + +testDB3 :: String +testDB3 = "tests/tmp/smp-agent3.test.protocol.db" + +smpAgentTest :: ARawTransmission -> IO ARawTransmission +smpAgentTest cmd = runSmpAgentTest $ \h -> tPutRaw h cmd >> tGetRaw h + +runSmpAgentTest :: (MonadUnliftIO m, MonadRandom m) => (Handle -> m a) -> m a +runSmpAgentTest test = withSmpServer . withSmpAgent $ testSMPAgentClient test + +runSmpAgentServerTest :: (MonadUnliftIO m, MonadRandom m) => ((ThreadId, ThreadId) -> Handle -> m a) -> m a +runSmpAgentServerTest test = + withSmpServerThreadOn testPort $ + \server -> withSmpAgentThreadOn (agentTestPort, testPort, testDB) $ + \agent -> testSMPAgentClient $ test (server, agent) + +smpAgentServerTest :: ((ThreadId, ThreadId) -> Handle -> IO ()) -> Expectation +smpAgentServerTest test' = runSmpAgentServerTest test' `shouldReturn` () + +runSmpAgentTestN :: forall m a. (MonadUnliftIO m, MonadRandom m) => [(ServiceName, ServiceName, String)] -> ([Handle] -> m a) -> m a +runSmpAgentTestN agents test = withSmpServer $ run agents [] + where + run :: [(ServiceName, ServiceName, String)] -> [Handle] -> m a + run [] hs = test hs + run (a@(p, _, _) : as) hs = withSmpAgentOn a $ testSMPAgentClientOn p $ \h -> run as (h : hs) + +runSmpAgentTestN_1 :: forall m a. (MonadUnliftIO m, MonadRandom m) => Int -> ([Handle] -> m a) -> m a +runSmpAgentTestN_1 nClients test = withSmpServer . withSmpAgent $ run nClients [] + where + run :: Int -> [Handle] -> m a + run 0 hs = test hs + run n hs = testSMPAgentClient $ \h -> run (n - 1) (h : hs) + +smpAgentTestN :: [(ServiceName, ServiceName, String)] -> ([Handle] -> IO ()) -> Expectation +smpAgentTestN agents test' = runSmpAgentTestN agents test' `shouldReturn` () + +smpAgentTestN_1 :: Int -> ([Handle] -> IO ()) -> Expectation +smpAgentTestN_1 n test' = runSmpAgentTestN_1 n test' `shouldReturn` () + +smpAgentTest2_2_2 :: (Handle -> Handle -> IO ()) -> Expectation +smpAgentTest2_2_2 test' = + withSmpServerOn testPort2 $ + smpAgentTestN + [ (agentTestPort, testPort, testDB), + (agentTestPort2, testPort2, testDB2) + ] + _test + where + _test [h1, h2] = test' h1 h2 + _test _ = error "expected 2 handles" + +smpAgentTest2_2_1 :: (Handle -> Handle -> IO ()) -> Expectation +smpAgentTest2_2_1 test' = + smpAgentTestN + [ (agentTestPort, testPort, testDB), + (agentTestPort2, testPort, testDB2) + ] + _test + where + _test [h1, h2] = test' h1 h2 + _test _ = error "expected 2 handles" + +smpAgentTest2_1_1 :: (Handle -> Handle -> IO ()) -> Expectation +smpAgentTest2_1_1 test' = smpAgentTestN_1 2 _test + where + _test [h1, h2] = test' h1 h2 + _test _ = error "expected 2 handles" + +smpAgentTest3 :: (Handle -> Handle -> Handle -> IO ()) -> Expectation +smpAgentTest3 test' = + smpAgentTestN + [ (agentTestPort, testPort, testDB), + (agentTestPort2, testPort, testDB2), + (agentTestPort3, testPort, testDB3) + ] + _test + where + _test [h1, h2, h3] = test' h1 h2 h3 + _test _ = error "expected 3 handles" + +smpAgentTest3_1_1 :: (Handle -> Handle -> Handle -> IO ()) -> Expectation +smpAgentTest3_1_1 test' = smpAgentTestN_1 3 _test + where + _test [h1, h2, h3] = test' h1 h2 h3 + _test _ = error "expected 3 handles" + +cfg :: AgentConfig +cfg = + AgentConfig + { tcpPort = agentTestPort, + smpServers = L.fromList ["localhost:5000#KXNE1m2E1m0lm92WGKet9CL6+lO742Vy5G6nsrkvgs8="], + rsaKeySize = 2048 `div` 8, + connIdBytes = 12, + tbqSize = 1, + dbFile = testDB, + smpCfg = + smpDefaultConfig + { qSize = 1, + defaultPort = testPort, + tcpTimeout = 500_000 + } + } + +withSmpAgentThreadOn :: (MonadUnliftIO m, MonadRandom m) => (ServiceName, ServiceName, String) -> (ThreadId -> m a) -> m a +withSmpAgentThreadOn (port', smpPort', db') = + let cfg' = cfg {tcpPort = port', dbFile = db', smpServers = L.fromList [SMPServer "localhost" (Just smpPort') testKeyHash]} + in serverBracket + (`runSMPAgentBlocking` cfg') + (removeFile db') + +withSmpAgentOn :: (MonadUnliftIO m, MonadRandom m) => (ServiceName, ServiceName, String) -> m a -> m a +withSmpAgentOn (port', smpPort', db') = withSmpAgentThreadOn (port', smpPort', db') . const + +withSmpAgent :: (MonadUnliftIO m, MonadRandom m) => m a -> m a +withSmpAgent = withSmpAgentOn (agentTestPort, testPort, testDB) + +testSMPAgentClientOn :: MonadUnliftIO m => ServiceName -> (Handle -> m a) -> m a +testSMPAgentClientOn port' client = do + runTCPClient agentTestHost port' $ \h -> do + line <- liftIO $ getLn h + if line == "Welcome to SMP v0.3.1 agent" + then client h + else error $ "wrong welcome message: " <> B.unpack line + +testSMPAgentClient :: MonadUnliftIO m => (Handle -> m a) -> m a +testSMPAgentClient = testSMPAgentClientOn agentTestPort diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs new file mode 100644 --- /dev/null +++ b/tests/SMPClient.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module SMPClient where + +import Control.Monad (void) +import Control.Monad.Except (runExceptT) +import Control.Monad.IO.Unlift +import Crypto.Random +import Data.ByteString.Base64 (encode) +import qualified Data.ByteString.Char8 as B +import Network.Socket +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Protocol +import Simplex.Messaging.Server (runSMPServerBlocking) +import Simplex.Messaging.Server.Env.STM +import Simplex.Messaging.Server.StoreLog (openReadStoreLog) +import Simplex.Messaging.Transport +import Test.Hspec +import UnliftIO.Concurrent +import qualified UnliftIO.Exception as E +import UnliftIO.STM (TMVar, atomically, newEmptyTMVarIO, takeTMVar) +import UnliftIO.Timeout (timeout) + +testHost :: HostName +testHost = "localhost" + +testPort :: ServiceName +testPort = "5000" + +testPort2 :: ServiceName +testPort2 = "5001" + +testKeyHashStr :: B.ByteString +testKeyHashStr = "KXNE1m2E1m0lm92WGKet9CL6+lO742Vy5G6nsrkvgs8=" + +testKeyHash :: Maybe C.KeyHash +testKeyHash = Just "KXNE1m2E1m0lm92WGKet9CL6+lO742Vy5G6nsrkvgs8=" + +testStoreLogFile :: FilePath +testStoreLogFile = "tests/tmp/smp-server-store.log" + +testSMPClient :: MonadUnliftIO m => (THandle -> m a) -> m a +testSMPClient client = + runTCPClient testHost testPort $ \h -> + liftIO (runExceptT $ clientHandshake h testKeyHash) >>= \case + Right th -> client th + Left e -> error $ show e + +cfg :: ServerConfig +cfg = + ServerConfig + { tcpPort = testPort, + tbqSize = 1, + queueIdBytes = 12, + msgIdBytes = 6, + storeLog = Nothing, + serverPrivateKey = + -- full RSA private key (only for tests) + "MIIFIwIBAAKCAQEArZyrri/NAwt5buvYjwu+B/MQeJUszDBpRgVqNddlI9kNwDXu\ + \kaJ8chEhrtaUgXeSWGooWwqjXEUQE6RVbCC6QVo9VEBSP4xFwVVd9Fj7OsgfcXXh\ + \AqWxfctDcBZQ5jTUiJpdBc+Vz2ZkumVNl0W+j9kWm9nfkMLQj8c0cVSDxz4OKpZb\ + \qFuj0uzHkis7e7wsrKSKWLPg3M5ZXPZM1m9qn7SfJzDRDfJifamxWI7uz9XK2+Dp\ + \NkUQlGQgFJEv1cKN88JAwIqZ1s+TAQMQiB+4QZ2aNfSqGEzRJN7FMCKRK7pM0A9A\ + \PCnijyuImvKFxTdk8Bx1q+XNJzsY6fBrLWJZ+QKBgQCySG4tzlcEm+tOVWRcwrWh\ + \6zsczGZp9mbf9c8itRx6dlldSYuDG1qnddL70wuAZF2AgS1JZgvcRZECoZRoWP5q\ + \Kq2wvpTIYjFPpC39lxgUoA/DXKVKZZdan+gwaVPAPT54my1CS32VrOiAY4gVJ3LJ\ + \Mn1/FqZXUFQA326pau3loQKCAQEAoljmJMp88EZoy3HlHUbOjl5UEhzzVsU1TnQi\ + \QmPm+aWRe2qelhjW4aTvSVE5mAUJsN6UWTeMf4uvM69Z9I5pfw2pEm8x4+GxRibY\ + \iiwF2QNaLxxmzEHm1zQQPTgb39o8mgklhzFPill0JsnL3f6IkVwjFJofWSmpqEGs\ + \dFSMRSXUTVXh1p/o7QZrhpwO/475iWKVS7o48N/0Xp513re3aXw+DRNuVnFEaBIe\ + \TLvWM9Czn16ndAu1HYiTBuMvtRbAWnGZxU8ewzF4wlWK5tdIL5PTJDd1VhZJAKtB\ + \npDvJpwxzKmjAhcTmjx0ckMIWtdVaOVm/2gWCXDty2FEdg7koQKBgQDOUUguJ/i7\ + \q0jldWYRnVkotKnpInPdcEaodrehfOqYEHnvro9xlS6OeAS4Vz5AdH45zQ/4J3bV\ + \2cH66tNr18ebM9nL//t5G69i89R9W7szyUxCI3LmAIdi3oSEbmz5GQBaw4l6h9Wi\ + \n4FmFQaAXZrjQfO2qJcAHvWRsMp2pmqAGwKBgQDXaza0DRsKWywWznsHcmHa0cx8\ + \I4jxqGaQmLO7wBJRP1NSFrywy1QfYrVX9CTLBK4V3F0PCgZ01Qv94751CzN43TgF\ + \ebd/O9r5NjNTnOXzdWqETbCffLGd6kLgCMwPQWpM9ySVjXHWCGZsRAnF2F6M1O32\ + \43StIifvwJQFqSM3ewKBgCaW6y7sRY90Ua7283RErezd9EyT22BWlDlACrPu3FNC\ + \LtBf1j43uxBWBQrMLsHe2GtTV0xt9m0MfwZsm2gSsXcm4Xi4DJgfN+Z7rIlyy9UY\ + \PCDSdZiU1qSr+NrffDrXlfiAM1cUmCdUX7eKjp/ltkUHNaOGfSn5Pdr3MkAiD/Hf\ + \AoGBAKIdKCuOwuYlwjS9J+IRGuSSM4o+OxQdwGmcJDTCpyWb5dEk68e7xKIna3zf\ + \jc+H+QdMXv1nkRK9bZgYheXczsXaNZUSTwpxaEldzVD3hNvsXSgJRy9fqHwA4PBq\ + \vqiBHoO3RNbqg+2rmTMfDuXreME3S955ZiPZm4Z+T8Hj52mPAoGAQm5QH/gLFtY5\ + \+znqU/0G8V6BKISCQMxbbmTQVcTgGySrP2gVd+e4MWvUttaZykhWqs8rpr7mgpIY\ + \hul7Swx0SHFN3WpXu8uj+B6MLpRcCbDHO65qU4kQLs+IaXXsuuTjMvJ5LwjkZVrQ\ + \TmKzSAw7iVWwEUZR/PeiEKazqrpp9VU=" + } + +withSmpServerStoreLogOn :: (MonadUnliftIO m, MonadRandom m) => ServiceName -> (ThreadId -> m a) -> m a +withSmpServerStoreLogOn port client = do + s <- liftIO $ openReadStoreLog testStoreLogFile + serverBracket + (\started -> runSMPServerBlocking started cfg {tcpPort = port, storeLog = Just s}) + (pure ()) + client + +withSmpServerThreadOn :: (MonadUnliftIO m, MonadRandom m) => ServiceName -> (ThreadId -> m a) -> m a +withSmpServerThreadOn port = + serverBracket + (\started -> runSMPServerBlocking started cfg {tcpPort = port}) + (pure ()) + +serverBracket :: MonadUnliftIO m => (TMVar Bool -> m ()) -> m () -> (ThreadId -> m a) -> m a +serverBracket process afterProcess f = do + started <- newEmptyTMVarIO + E.bracket + (forkIOWithUnmask ($ process started)) + (\t -> killThread t >> afterProcess >> waitFor started "stop") + (\t -> waitFor started "start" >> f t) + where + waitFor started s = + 5_000_000 `timeout` atomically (takeTMVar started) >>= \case + Nothing -> error $ "server did not " <> s + _ -> pure () + +withSmpServerOn :: (MonadUnliftIO m, MonadRandom m) => ServiceName -> m a -> m a +withSmpServerOn port = withSmpServerThreadOn port . const + +withSmpServer :: (MonadUnliftIO m, MonadRandom m) => m a -> m a +withSmpServer = withSmpServerOn testPort + +runSmpTest :: (MonadUnliftIO m, MonadRandom m) => (THandle -> m a) -> m a +runSmpTest test = withSmpServer $ testSMPClient test + +runSmpTestN :: forall m a. (MonadUnliftIO m, MonadRandom m) => Int -> ([THandle] -> m a) -> m a +runSmpTestN nClients test = withSmpServer $ run nClients [] + where + run :: Int -> [THandle] -> m a + run 0 hs = test hs + run n hs = testSMPClient $ \h -> run (n - 1) (h : hs) + +smpServerTest :: RawTransmission -> IO RawTransmission +smpServerTest cmd = runSmpTest $ \h -> tPutRaw h cmd >> tGetRaw h + +smpTest :: (THandle -> IO ()) -> Expectation +smpTest test' = runSmpTest test' `shouldReturn` () + +smpTestN :: Int -> ([THandle] -> IO ()) -> Expectation +smpTestN n test' = runSmpTestN n test' `shouldReturn` () + +smpTest2 :: (THandle -> THandle -> IO ()) -> Expectation +smpTest2 test' = smpTestN 2 _test + where + _test [h1, h2] = test' h1 h2 + _test _ = error "expected 2 handles" + +smpTest3 :: (THandle -> THandle -> THandle -> IO ()) -> Expectation +smpTest3 test' = smpTestN 3 _test + where + _test [h1, h2, h3] = test' h1 h2 h3 + _test _ = error "expected 3 handles" + +tPutRaw :: THandle -> RawTransmission -> IO () +tPutRaw h (sig, corrId, queueId, command) = do + let t = B.intercalate " " [corrId, queueId, command] + void $ tPut h (C.Signature sig, t) + +tGetRaw :: THandle -> IO RawTransmission +tGetRaw h = do + ("", (CorrId corrId, qId, Right cmd)) <- tGet fromServer h + pure ("", corrId, encode qId, serializeCommand cmd) diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs new file mode 100644 --- /dev/null +++ b/tests/ServerTests.hs @@ -0,0 +1,416 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module ServerTests where + +import Control.Concurrent (ThreadId, killThread) +import Control.Concurrent.STM +import Control.Exception (SomeException, try) +import Control.Monad.Except (forM_, runExceptT) +import Data.ByteString.Base64 +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import SMPClient +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Protocol +import Simplex.Messaging.Transport +import System.Directory (removeFile) +import System.TimeIt (timeItT) +import System.Timeout +import Test.HUnit +import Test.Hspec + +rsaKeySize :: Int +rsaKeySize = 2048 `div` 8 + +serverTests :: Spec +serverTests = do + describe "SMP syntax" syntaxTests + describe "SMP queues" do + describe "NEW and KEY commands, SEND messages" testCreateSecure + describe "NEW, OFF and DEL commands, SEND messages" testCreateDelete + describe "SMP messages" do + describe "duplex communication over 2 SMP connections" testDuplex + describe "switch subscription to another SMP queue" testSwitchSub + describe "Store log" testWithStoreLog + describe "Timing of AUTH error" testTiming + +pattern Resp :: CorrId -> QueueId -> Command 'Broker -> SignedTransmissionOrError +pattern Resp corrId queueId command <- ("", (corrId, queueId, Right (Cmd SBroker command))) + +sendRecv :: THandle -> (ByteString, ByteString, ByteString, ByteString) -> IO SignedTransmissionOrError +sendRecv h (sgn, corrId, qId, cmd) = tPutRaw h (sgn, corrId, encode qId, cmd) >> tGet fromServer h + +signSendRecv :: THandle -> C.SafePrivateKey -> (ByteString, ByteString, ByteString) -> IO SignedTransmissionOrError +signSendRecv h pk (corrId, qId, cmd) = do + let t = B.intercalate " " [corrId, encode qId, cmd] + Right sig <- runExceptT $ C.sign pk t + _ <- tPut h (sig, t) + tGet fromServer h + +cmdSEND :: ByteString -> ByteString +cmdSEND msg = serializeCommand (Cmd SSender . SEND $ msg) + +(>#>) :: RawTransmission -> RawTransmission -> Expectation +command >#> response = smpServerTest command `shouldReturn` response + +(#==) :: (HasCallStack, Eq a, Show a) => (a, a) -> String -> Assertion +(actual, expected) #== message = assertEqual message expected actual + +testCreateSecure :: Spec +testCreateSecure = + it "should create (NEW) and secure (KEY) queue" $ + smpTest \h -> do + (rPub, rKey) <- C.generateKeyPair rsaKeySize + Resp "abcd" rId1 (IDS rId sId) <- signSendRecv h rKey ("abcd", "", "NEW " <> C.serializePubKey rPub) + (rId1, "") #== "creates queue" + + Resp "bcda" sId1 ok1 <- sendRecv h ("", "bcda", sId, "SEND 5 hello ") + (ok1, OK) #== "accepts unsigned SEND" + (sId1, sId) #== "same queue ID in response 1" + + Resp "" _ (MSG _ _ msg1) <- tGet fromServer h + (msg1, "hello") #== "delivers message" + + Resp "cdab" _ ok4 <- signSendRecv h rKey ("cdab", rId, "ACK") + (ok4, OK) #== "replies OK when message acknowledged if no more messages" + + Resp "dabc" _ err6 <- signSendRecv h rKey ("dabc", rId, "ACK") + (err6, ERR NO_MSG) #== "replies ERR when message acknowledged without messages" + + (sPub, sKey) <- C.generateKeyPair rsaKeySize + Resp "abcd" sId2 err1 <- signSendRecv h sKey ("abcd", sId, "SEND 5 hello ") + (err1, ERR AUTH) #== "rejects signed SEND" + (sId2, sId) #== "same queue ID in response 2" + + let keyCmd = "KEY " <> C.serializePubKey sPub + Resp "bcda" _ err2 <- sendRecv h (sampleSig, "bcda", rId, keyCmd) + (err2, ERR AUTH) #== "rejects KEY with wrong signature" + + Resp "cdab" _ err3 <- signSendRecv h rKey ("cdab", sId, keyCmd) + (err3, ERR AUTH) #== "rejects KEY with sender's ID" + + Resp "dabc" rId2 ok2 <- signSendRecv h rKey ("dabc", rId, keyCmd) + (ok2, OK) #== "secures queue" + (rId2, rId) #== "same queue ID in response 3" + + Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, keyCmd) + (err4, ERR AUTH) #== "rejects KEY if already secured" + + Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, "SEND 11 hello again ") + (ok3, OK) #== "accepts signed SEND" + + Resp "" _ (MSG _ _ msg) <- tGet fromServer h + (msg, "hello again") #== "delivers message 2" + + Resp "cdab" _ ok5 <- signSendRecv h rKey ("cdab", rId, "ACK") + (ok5, OK) #== "replies OK when message acknowledged 2" + + Resp "dabc" _ err5 <- sendRecv h ("", "dabc", sId, "SEND 5 hello ") + (err5, ERR AUTH) #== "rejects unsigned SEND" + +testCreateDelete :: Spec +testCreateDelete = + it "should create (NEW), suspend (OFF) and delete (DEL) queue" $ + smpTest2 \rh sh -> do + (rPub, rKey) <- C.generateKeyPair rsaKeySize + Resp "abcd" rId1 (IDS rId sId) <- signSendRecv rh rKey ("abcd", "", "NEW " <> C.serializePubKey rPub) + (rId1, "") #== "creates queue" + + (sPub, sKey) <- C.generateKeyPair rsaKeySize + Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, "KEY " <> C.serializePubKey sPub) + (ok1, OK) #== "secures queue" + + Resp "cdab" _ ok2 <- signSendRecv sh sKey ("cdab", sId, "SEND 5 hello ") + (ok2, OK) #== "accepts signed SEND" + + Resp "dabc" _ ok7 <- signSendRecv sh sKey ("dabc", sId, "SEND 7 hello 2 ") + (ok7, OK) #== "accepts signed SEND 2 - this message is not delivered because the first is not ACKed" + + Resp "" _ (MSG _ _ msg1) <- tGet fromServer rh + (msg1, "hello") #== "delivers message" + + Resp "abcd" _ err1 <- sendRecv rh (sampleSig, "abcd", rId, "OFF") + (err1, ERR AUTH) #== "rejects OFF with wrong signature" + + Resp "bcda" _ err2 <- signSendRecv rh rKey ("bcda", sId, "OFF") + (err2, ERR AUTH) #== "rejects OFF with sender's ID" + + Resp "cdab" rId2 ok3 <- signSendRecv rh rKey ("cdab", rId, "OFF") + (ok3, OK) #== "suspends queue" + (rId2, rId) #== "same queue ID in response 2" + + Resp "dabc" _ err3 <- signSendRecv sh sKey ("dabc", sId, "SEND 5 hello ") + (err3, ERR AUTH) #== "rejects signed SEND" + + Resp "abcd" _ err4 <- sendRecv sh ("", "abcd", sId, "SEND 5 hello ") + (err4, ERR AUTH) #== "reject unsigned SEND too" + + Resp "bcda" _ ok4 <- signSendRecv rh rKey ("bcda", rId, "OFF") + (ok4, OK) #== "accepts OFF when suspended" + + Resp "cdab" _ (MSG _ _ msg) <- signSendRecv rh rKey ("cdab", rId, "SUB") + (msg, "hello") #== "accepts SUB when suspended and delivers the message again (because was not ACKed)" + + Resp "dabc" _ err5 <- sendRecv rh (sampleSig, "dabc", rId, "DEL") + (err5, ERR AUTH) #== "rejects DEL with wrong signature" + + Resp "abcd" _ err6 <- signSendRecv rh rKey ("abcd", sId, "DEL") + (err6, ERR AUTH) #== "rejects DEL with sender's ID" + + Resp "bcda" rId3 ok6 <- signSendRecv rh rKey ("bcda", rId, "DEL") + (ok6, OK) #== "deletes queue" + (rId3, rId) #== "same queue ID in response 3" + + Resp "cdab" _ err7 <- signSendRecv sh sKey ("cdab", sId, "SEND 5 hello ") + (err7, ERR AUTH) #== "rejects signed SEND when deleted" + + Resp "dabc" _ err8 <- sendRecv sh ("", "dabc", sId, "SEND 5 hello ") + (err8, ERR AUTH) #== "rejects unsigned SEND too when deleted" + + Resp "abcd" _ err11 <- signSendRecv rh rKey ("abcd", rId, "ACK") + (err11, ERR AUTH) #== "rejects ACK when conn deleted - the second message is deleted" + + Resp "bcda" _ err9 <- signSendRecv rh rKey ("bcda", rId, "OFF") + (err9, ERR AUTH) #== "rejects OFF when deleted" + + Resp "cdab" _ err10 <- signSendRecv rh rKey ("cdab", rId, "SUB") + (err10, ERR AUTH) #== "rejects SUB when deleted" + +testDuplex :: Spec +testDuplex = + it "should create 2 simplex connections and exchange messages" $ + smpTest2 \alice bob -> do + (arPub, arKey) <- C.generateKeyPair rsaKeySize + Resp "abcd" _ (IDS aRcv aSnd) <- signSendRecv alice arKey ("abcd", "", "NEW " <> C.serializePubKey arPub) + -- aSnd ID is passed to Bob out-of-band + + (bsPub, bsKey) <- C.generateKeyPair rsaKeySize + Resp "bcda" _ OK <- sendRecv bob ("", "bcda", aSnd, cmdSEND $ "key " <> C.serializePubKey bsPub) + -- "key ..." is ad-hoc, different from SMP protocol + + Resp "" _ (MSG _ _ msg1) <- tGet fromServer alice + Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, "ACK") + ["key", bobKey] <- return $ B.words msg1 + (bobKey, C.serializePubKey bsPub) #== "key received from Bob" + Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, "KEY " <> bobKey) + + (brPub, brKey) <- C.generateKeyPair rsaKeySize + Resp "abcd" _ (IDS bRcv bSnd) <- signSendRecv bob brKey ("abcd", "", "NEW " <> C.serializePubKey brPub) + Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, cmdSEND $ "reply_id " <> encode bSnd) + -- "reply_id ..." is ad-hoc, it is not a part of SMP protocol + + Resp "" _ (MSG _ _ msg2) <- tGet fromServer alice + Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, "ACK") + ["reply_id", bId] <- return $ B.words msg2 + (bId, encode bSnd) #== "reply queue ID received from Bob" + + (asPub, asKey) <- C.generateKeyPair rsaKeySize + Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, cmdSEND $ "key " <> C.serializePubKey asPub) + -- "key ..." is ad-hoc, different from SMP protocol + + Resp "" _ (MSG _ _ msg3) <- tGet fromServer bob + Resp "abcd" _ OK <- signSendRecv bob brKey ("abcd", bRcv, "ACK") + ["key", aliceKey] <- return $ B.words msg3 + (aliceKey, C.serializePubKey asPub) #== "key received from Alice" + Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, "KEY " <> aliceKey) + + Resp "cdab" _ OK <- signSendRecv bob bsKey ("cdab", aSnd, "SEND 8 hi alice ") + + Resp "" _ (MSG _ _ msg4) <- tGet fromServer alice + Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, "ACK") + (msg4, "hi alice") #== "message received from Bob" + + Resp "abcd" _ OK <- signSendRecv alice asKey ("abcd", bSnd, cmdSEND "how are you bob") + + Resp "" _ (MSG _ _ msg5) <- tGet fromServer bob + Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, "ACK") + (msg5, "how are you bob") #== "message received from alice" + +testSwitchSub :: Spec +testSwitchSub = + it "should create simplex connections and switch subscription to another TCP connection" $ + smpTest3 \rh1 rh2 sh -> do + (rPub, rKey) <- C.generateKeyPair rsaKeySize + Resp "abcd" _ (IDS rId sId) <- signSendRecv rh1 rKey ("abcd", "", "NEW " <> C.serializePubKey rPub) + Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, "SEND 5 test1 ") + (ok1, OK) #== "sent test message 1" + Resp "cdab" _ ok2 <- sendRecv sh ("", "cdab", sId, cmdSEND "test2, no ACK") + (ok2, OK) #== "sent test message 2" + + Resp "" _ (MSG _ _ msg1) <- tGet fromServer rh1 + (msg1, "test1") #== "test message 1 delivered to the 1st TCP connection" + Resp "abcd" _ (MSG _ _ msg2) <- signSendRecv rh1 rKey ("abcd", rId, "ACK") + (msg2, "test2, no ACK") #== "test message 2 delivered, no ACK" + + Resp "bcda" _ (MSG _ _ msg2') <- signSendRecv rh2 rKey ("bcda", rId, "SUB") + (msg2', "test2, no ACK") #== "same simplex queue via another TCP connection, tes2 delivered again (no ACK in 1st queue)" + Resp "cdab" _ OK <- signSendRecv rh2 rKey ("cdab", rId, "ACK") + + Resp "" _ end <- tGet fromServer rh1 + (end, END) #== "unsubscribed the 1st TCP connection" + + Resp "dabc" _ OK <- sendRecv sh ("", "dabc", sId, "SEND 5 test3 ") + + Resp "" _ (MSG _ _ msg3) <- tGet fromServer rh2 + (msg3, "test3") #== "delivered to the 2nd TCP connection" + + Resp "abcd" _ err <- signSendRecv rh1 rKey ("abcd", rId, "ACK") + (err, ERR NO_MSG) #== "rejects ACK from the 1st TCP connection" + + Resp "bcda" _ ok3 <- signSendRecv rh2 rKey ("bcda", rId, "ACK") + (ok3, OK) #== "accepts ACK from the 2nd TCP connection" + + 1000 `timeout` tGet fromServer rh1 >>= \case + Nothing -> return () + Just _ -> error "nothing else is delivered to the 1st TCP connection" + +testWithStoreLog :: Spec +testWithStoreLog = + it "should store simplex queues to log and restore them after server restart" $ do + (sPub1, sKey1) <- C.generateKeyPair rsaKeySize + (sPub2, sKey2) <- C.generateKeyPair rsaKeySize + senderId1 <- newTVarIO "" + senderId2 <- newTVarIO "" + + withSmpServerStoreLogOn testPort . runTest $ \h -> do + (sId1, _, _) <- createAndSecureQueue h sPub1 + atomically $ writeTVar senderId1 sId1 + Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, "SEND 5 hello ") + Resp "" _ (MSG _ _ "hello") <- tGet fromServer h + + (sId2, rId2, rKey2) <- createAndSecureQueue h sPub2 + atomically $ writeTVar senderId2 sId2 + Resp "cdab" _ OK <- signSendRecv h sKey2 ("cdab", sId2, "SEND 9 hello too ") + Resp "" _ (MSG _ _ "hello too") <- tGet fromServer h + + Resp "dabc" _ OK <- signSendRecv h rKey2 ("dabc", rId2, "DEL") + pure () + + logSize `shouldReturn` 5 + + withSmpServerThreadOn testPort . runTest $ \h -> do + sId1 <- readTVarIO senderId1 + -- fails if store log is disabled + Resp "bcda" _ (ERR AUTH) <- signSendRecv h sKey1 ("bcda", sId1, "SEND 5 hello ") + pure () + + withSmpServerStoreLogOn testPort . runTest $ \h -> do + -- this queue is restored + sId1 <- readTVarIO senderId1 + Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, "SEND 5 hello ") + -- this queue is removed - not restored + sId2 <- readTVarIO senderId2 + Resp "cdab" _ (ERR AUTH) <- signSendRecv h sKey2 ("cdab", sId2, "SEND 9 hello too ") + pure () + + logSize `shouldReturn` 1 + removeFile testStoreLogFile + where + createAndSecureQueue :: THandle -> SenderPublicKey -> IO (SenderId, RecipientId, C.SafePrivateKey) + createAndSecureQueue h sPub = do + (rPub, rKey) <- C.generateKeyPair rsaKeySize + Resp "abcd" "" (IDS rId sId) <- signSendRecv h rKey ("abcd", "", "NEW " <> C.serializePubKey rPub) + let keyCmd = "KEY " <> C.serializePubKey sPub + Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, keyCmd) + (rId', rId) #== "same queue ID" + pure (sId, rId, rKey) + + runTest :: (THandle -> IO ()) -> ThreadId -> Expectation + runTest test' server = do + testSMPClient test' `shouldReturn` () + killThread server + + logSize :: IO Int + logSize = + try (length . B.lines <$> B.readFile testStoreLogFile) >>= \case + Right l -> pure l + Left (_ :: SomeException) -> logSize + +testTiming :: Spec +testTiming = + it "should have similar time for auth error, whether queue exists or not, for all key sizes" $ + smpTest2 \rh sh -> + mapM_ + (testSameTiming rh sh) + [ (128, 128, 100), + (128, 256, 25), + -- (128, 512, 15), + (256, 128, 100), + (256, 256, 25) + -- (256, 512, 15), + -- (512, 128, 100), + -- (512, 256, 25), + -- (512, 512, 15) + ] + where + timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const + similarTime t1 t2 = abs (t1 - t2) / t1 < 0.2 `shouldBe` True + testSameTiming :: THandle -> THandle -> (Int, Int, Int) -> Expectation + testSameTiming rh sh (senderKeySize, badKeySize, n) = do + (rPub, rKey) <- C.generateKeyPair rsaKeySize + Resp "abcd" "" (IDS rId sId) <- signSendRecv rh rKey ("abcd", "", "NEW " <> C.serializePubKey rPub) + + (sPub, sKey) <- C.generateKeyPair senderKeySize + let keyCmd = "KEY " <> C.serializePubKey sPub + Resp "dabc" _ OK <- signSendRecv rh rKey ("dabc", rId, keyCmd) + + (_, badKey) <- C.generateKeyPair badKeySize + Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, "SEND 5 hello ") + timeWrongKey <- timeRepeat n $ do + Resp "cdab" _ (ERR AUTH) <- signSendRecv sh badKey ("cdab", sId, "SEND 5 hello ") + return () + timeNoQueue <- timeRepeat n $ do + Resp "dabc" _ (ERR AUTH) <- signSendRecv sh badKey ("dabc", "1234", "SEND 5 hello ") + return () + Resp "" _ (MSG _ _ "hello") <- tGet fromServer rh + similarTime timeNoQueue timeWrongKey + +samplePubKey :: ByteString +samplePubKey = "rsa:MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAtn1NI2tPoOGSGfad0aUg0tJ0kG2nzrIPGLiz8wb3dQSJC9xkRHyzHhEE8Kmy2cM4q7rNZIlLcm4M7oXOTe7SC4x59bLQG9bteZPKqXu9wk41hNamV25PWQ4zIcIRmZKETVGbwN7jFMpH7wxLdI1zzMArAPKXCDCJ5ctWh4OWDI6OR6AcCtEj+toCI6N6pjxxn5VigJtwiKhxYpoUJSdNM60wVEDCSUrZYBAuDH8pOxPfP+Tm4sokaFDTIG3QJFzOjC+/9nW4MUjAOFll9PCp9kaEFHJ/YmOYKMWNOCCPvLS6lxA83i0UaardkNLNoFS5paWfTlroxRwOC2T6PwO2ywKBgDjtXcSED61zK1seocQMyGRINnlWdhceD669kIHju/f6kAayvYKW3/lbJNXCmyinAccBosO08/0sUxvtuniIo18kfYJE0UmP1ReCjhMP+O+yOmwZJini/QelJk/Pez8IIDDWnY1qYQsN/q7ocjakOYrpGG7mig6JMFpDJtD6istR" + +sampleSig :: ByteString +sampleSig = "\128\207*\159eq\220i!\"\157\161\130\184\226\246\232_\\\170`\180\160\230sI\154\197\211\252\SUB\246\206ELL\t9K\ESC\196?\128\215%\222\148\NAK;9\155f\164\217e\242\156\CAN9\253\r\170\174'w\211\228?\205)\215\150\255\247z\DC115\DC1{\bn\145\rKD,K\230\202d8\233\167|7y\t_S\EM\248\EOT\216\172\167d\181\224)\137\ACKo\197j#c\217\243\228.\167\228\205\144\vr\134" + +syntaxTests :: Spec +syntaxTests = do + it "unknown command" $ ("", "abcd", "1234", "HELLO") >#> ("", "abcd", "1234", "ERR CMD SYNTAX") + describe "NEW" do + it "no parameters" $ (sampleSig, "bcda", "", "NEW") >#> ("", "bcda", "", "ERR CMD SYNTAX") + it "many parameters" $ (sampleSig, "cdab", "", "NEW 1 " <> samplePubKey) >#> ("", "cdab", "", "ERR CMD SYNTAX") + it "no signature" $ ("", "dabc", "", "NEW " <> samplePubKey) >#> ("", "dabc", "", "ERR CMD NO_AUTH") + it "queue ID" $ (sampleSig, "abcd", "12345678", "NEW " <> samplePubKey) >#> ("", "abcd", "12345678", "ERR CMD HAS_AUTH") + describe "KEY" do + it "valid syntax" $ (sampleSig, "bcda", "12345678", "KEY " <> samplePubKey) >#> ("", "bcda", "12345678", "ERR AUTH") + it "no parameters" $ (sampleSig, "cdab", "12345678", "KEY") >#> ("", "cdab", "12345678", "ERR CMD SYNTAX") + it "many parameters" $ (sampleSig, "dabc", "12345678", "KEY 1 " <> samplePubKey) >#> ("", "dabc", "12345678", "ERR CMD SYNTAX") + it "no signature" $ ("", "abcd", "12345678", "KEY " <> samplePubKey) >#> ("", "abcd", "12345678", "ERR CMD NO_AUTH") + it "no queue ID" $ (sampleSig, "bcda", "", "KEY " <> samplePubKey) >#> ("", "bcda", "", "ERR CMD NO_AUTH") + noParamsSyntaxTest "SUB" + noParamsSyntaxTest "ACK" + noParamsSyntaxTest "OFF" + noParamsSyntaxTest "DEL" + describe "SEND" do + it "valid syntax 1" $ (sampleSig, "cdab", "12345678", "SEND 5 hello ") >#> ("", "cdab", "12345678", "ERR AUTH") + it "valid syntax 2" $ (sampleSig, "dabc", "12345678", "SEND 11 hello there ") >#> ("", "dabc", "12345678", "ERR AUTH") + it "no parameters" $ (sampleSig, "abcd", "12345678", "SEND") >#> ("", "abcd", "12345678", "ERR CMD SYNTAX") + it "no queue ID" $ (sampleSig, "bcda", "", "SEND 5 hello ") >#> ("", "bcda", "", "ERR CMD NO_QUEUE") + it "bad message body 1" $ (sampleSig, "cdab", "12345678", "SEND 11 hello ") >#> ("", "cdab", "12345678", "ERR CMD SYNTAX") + it "bad message body 2" $ (sampleSig, "dabc", "12345678", "SEND hello ") >#> ("", "dabc", "12345678", "ERR CMD SYNTAX") + it "bigger body" $ (sampleSig, "abcd", "12345678", "SEND 4 hello ") >#> ("", "abcd", "12345678", "ERR CMD SYNTAX") + describe "PING" do + it "valid syntax" $ ("", "abcd", "", "PING") >#> ("", "abcd", "", "PONG") + describe "broker response not allowed" do + it "OK" $ (sampleSig, "bcda", "12345678", "OK") >#> ("", "bcda", "12345678", "ERR CMD PROHIBITED") + where + noParamsSyntaxTest :: ByteString -> Spec + noParamsSyntaxTest cmd = describe (B.unpack cmd) do + it "valid syntax" $ (sampleSig, "abcd", "12345678", cmd) >#> ("", "abcd", "12345678", "ERR AUTH") + it "wrong terminator" $ (sampleSig, "bcda", "12345678", cmd <> "=") >#> ("", "bcda", "12345678", "ERR CMD SYNTAX") + it "no signature" $ ("", "cdab", "12345678", cmd) >#> ("", "cdab", "12345678", "ERR CMD NO_AUTH") + it "no queue ID" $ (sampleSig, "dabc", "", cmd) >#> ("", "dabc", "", "ERR CMD NO_AUTH") diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -0,0 +1,14 @@ +import AgentTests +import ProtocolErrorTests +import ServerTests +import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive) +import Test.Hspec + +main :: IO () +main = do + createDirectoryIfMissing False "tests/tmp" + hspec $ do + describe "Protocol errors" protocolErrorTests + describe "SMP server" serverTests + describe "SMP client agent" agentTests + removeDirectoryRecursive "tests/tmp"