packages feed

simplexmq (empty) → 0.3.1

raw patch · 34 files changed

+7603/−0 lines, 34 filesdep +HUnitdep +QuickCheckdep +ansi-terminalsetup-changed

Dependencies added: HUnit, QuickCheck, ansi-terminal, asn1-encoding, asn1-types, async, attoparsec, base, base64-bytestring, bytestring, containers, cryptonite, cryptostore, directory, filepath, generic-random, hspec, hspec-core, ini, iso8601-time, memory, mtl, network, network-transport, optparse-applicative, random, simple-logger, simplexmq, sqlite-simple, stm, template-haskell, text, time, timeit, transformers, unliftio, unliftio-core, x509

Files

+ CHANGELOG.md view
@@ -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
+ LICENSE view
@@ -0,0 +1,661 @@+                    GNU AFFERO GENERAL PUBLIC LICENSE+                       Version 3, 19 November 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>+ 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.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This program is free software: you can redistribute it and/or modify+    it under the terms of the GNU 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 <https://www.gnu.org/licenses/>.++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+<https://www.gnu.org/licenses/>.
+ README.md view
@@ -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: `<hostname>:5223#<key hash>`.++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)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ apps/smp-agent/Main.hs view
@@ -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
+ apps/smp-server/Main.hs view
@@ -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)"+        )
+ simplexmq.cabal view
@@ -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:+                .+                * <https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md SMP protocol>+                * <https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md SMP agent protocol>+                .+                See <https://github.com/simplex-chat/simplex-chat terminal chat prototype> 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
+ src/Simplex/Messaging/Agent.hs view
@@ -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 <KEY>"+          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 <HELLO>"+          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 <REPLY>"+          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 <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)
+ src/Simplex/Messaging/Agent/Client.hs view
@@ -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 <KEY>" $ \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 <HELLO> (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 <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 <message>" $ \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
+ src/Simplex/Messaging/Agent/Env/SQLite.hs view
@@ -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)
+ src/Simplex/Messaging/Agent/Protocol.hs view
@@ -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 <https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message SMP protocol>)+    SMPConfirmation SenderPublicKey+  | -- | Agent message header and envelope for client messages+    -- (see <https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md#messages-between-smp-agents SMP agent protocol>)+    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
+ src/Simplex/Messaging/Agent/Store.hs view
@@ -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)
+ src/Simplex/Messaging/Agent/Store/SQLite.hs view
@@ -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+    ]
+ src/Simplex/Messaging/Agent/Store/SQLite/Schema.hs view
@@ -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;+  |]
+ src/Simplex/Messaging/Client.hs view
@@ -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
+ src/Simplex/Messaging/Crypto.hs view
@@ -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+-- <https://hackage.haskell.org/package/cryptonite cryptonite package>.+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"
+ src/Simplex/Messaging/Parsers.hs view
@@ -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"
+ src/Simplex/Messaging/Protocol.hs view
@@ -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
+ src/Simplex/Messaging/Server.hs view
@@ -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
+ src/Simplex/Messaging/Server/Env/STM.hs view
@@ -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)
+ src/Simplex/Messaging/Server/MsgStore.hs view
@@ -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
+ src/Simplex/Messaging/Server/MsgStore/STM.hs view
@@ -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
+ src/Simplex/Messaging/Server/QueueStore.hs view
@@ -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+    }
+ src/Simplex/Messaging/Server/QueueStore/STM.hs view
@@ -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
+ src/Simplex/Messaging/Server/StoreLog.hs view
@@ -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
+ src/Simplex/Messaging/Transport.hs view
@@ -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+      }
+ src/Simplex/Messaging/Util.hs view
@@ -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)
+ tests/AgentTests.hs view
@@ -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")
+ tests/AgentTests/SQLiteTests.hs view
@@ -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"
+ tests/ProtocolErrorTests.hs view
@@ -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)
+ tests/SMPAgentClient.hs view
@@ -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
+ tests/SMPClient.hs view
@@ -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)
+ tests/ServerTests.hs view
@@ -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")
+ tests/Test.hs view
@@ -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"