diff --git a/ChangeLog.md b/ChangeLog.md
new file mode 100644
--- /dev/null
+++ b/ChangeLog.md
@@ -0,0 +1,10 @@
+# Revision history for haskell-magic-wormhole-client
+
+## 0.1.0.0 -- 2018-12-10
+
+* First version of the haskell port of magic-wormhole client.
+* The client can send and receive text messages, files and directories.
+* Supports sending to local computers or remote ones via relay.
+* Interoperable with the reference Brian Warner's Python client.
+* Ability to select custom transit server or relay server.
+* Completion help while typing the code at the receiver end.
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,674 @@
+ GNU GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc.
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The GNU General Public License is a free, copyleft license for
+software and other kinds of works.
+
+ The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works. By contrast,
+the GNU General Public License is intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains free
+software for all its users. We, the Free Software Foundation, use the
+GNU General Public License for most of our software; it applies also to
+any other work released this way by its authors. You can apply it to
+your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+them if you wish), that you receive source code or can get it if you
+want it, that you can change the software or use pieces of it in new
+free programs, and that you know you can do these things.
+
+ To protect your rights, we need to prevent others from denying you
+these rights or asking you to surrender the rights. Therefore, you have
+certain responsibilities if you distribute copies of the software, or if
+you modify it: responsibilities to respect the freedom of others.
+
+ For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must pass on to the recipients the same
+freedoms that you received. You must make sure that they, too, receive
+or can get the source code. And you must show them these terms so they
+know their rights.
+
+ Developers that use the GNU GPL protect your rights with two steps:
+(1) assert copyright on the software, and (2) offer you this License
+giving you legal permission to copy, distribute and/or modify it.
+
+ For the developers' and authors' protection, the GPL clearly explains
+that there is no warranty for this free software. For both users' and
+authors' sake, the GPL requires that modified versions be marked as
+changed, so that their problems will not be attributed erroneously to
+authors of previous versions.
+
+ Some devices are designed to deny users access to install or run
+modified versions of the software inside them, although the manufacturer
+can do so. This is fundamentally incompatible with the aim of
+protecting users' freedom to change the software. The systematic
+pattern of such abuse occurs in the area of products for individuals to
+use, which is precisely where it is most unacceptable. Therefore, we
+have designed this version of the GPL to prohibit the practice for those
+products. If such problems arise substantially in other domains, we
+stand ready to extend this provision to those domains in future versions
+of the GPL, as needed to protect the freedom of users.
+
+ Finally, every program is threatened constantly by software patents.
+States should not allow patents to restrict development and use of
+software on general-purpose computers, but in those that do, we wish to
+avoid the special danger that patents applied to a free program could
+make it effectively proprietary. To prevent this, the GPL assures that
+patents cannot be used to render the program non-free.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ TERMS AND CONDITIONS
+
+ 0. Definitions.
+
+ "This License" refers to version 3 of the GNU General Public License.
+
+ "Copyright" also means copyright-like laws that apply to other kinds of
+works, such as semiconductor masks.
+
+ "The Program" refers to any copyrightable work licensed under this
+License. Each licensee is addressed as "you". "Licensees" and
+"recipients" may be individuals or organizations.
+
+ To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of an
+exact copy. The resulting work is called a "modified version" of the
+earlier work or a work "based on" the earlier work.
+
+ A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+ To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy. Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+ To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies. Mere interaction with a user through
+a computer network, with no transfer of a copy, is not conveying.
+
+ An interactive user interface displays "Appropriate Legal Notices"
+to the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License. If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+ 1. Source Code.
+
+ The "source code" for a work means the preferred form of the work
+for making modifications to it. "Object code" means any non-source
+form of a work.
+
+ A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+ The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form. A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+ The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities. However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work. For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+ The Corresponding Source need not include anything that users
+can regenerate automatically from other parts of the Corresponding
+Source.
+
+ The Corresponding Source for a work in source code form is that
+same work.
+
+ 2. Basic Permissions.
+
+ All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met. This License explicitly affirms your unlimited
+permission to run the unmodified Program. The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work. This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+ You may make, run and propagate covered works that you do not
+convey, without conditions so long as your license otherwise remains
+in force. You may convey covered works to others for the sole purpose
+of having them make modifications exclusively for you, or provide you
+with facilities for running those works, provided that you comply with
+the terms of this License in conveying all material for which you do
+not control copyright. Those thus making or running the covered works
+for you must do so exclusively on your behalf, under your direction
+and control, on terms that prohibit them from making any copies of
+your copyrighted material outside their relationship with you.
+
+ Conveying under any other circumstances is permitted solely under
+the conditions stated below. Sublicensing is not allowed; section 10
+makes it unnecessary.
+
+ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+ No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+ When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such circumvention
+is effected by exercising rights under this License with respect to
+the covered work, and you disclaim any intention to limit operation or
+modification of the work as a means of enforcing, against the work's
+users, your or third parties' legal rights to forbid circumvention of
+technological measures.
+
+ 4. Conveying Verbatim Copies.
+
+ You may convey verbatim copies of the Program's source code as you
+receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+ You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+ 5. Conveying Modified Source Versions.
+
+ You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these conditions:
+
+ a) The work must carry prominent notices stating that you modified
+ it, and giving a relevant date.
+
+ b) The work must carry prominent notices stating that it is
+ released under this License and any conditions added under section
+ 7. This requirement modifies the requirement in section 4 to
+ "keep intact all notices".
+
+ c) You must license the entire work, as a whole, under this
+ License to anyone who comes into possession of a copy. This
+ License will therefore apply, along with any applicable section 7
+ additional terms, to the whole of the work, and all its parts,
+ regardless of how they are packaged. This License gives no
+ permission to license the work in any other way, but it does not
+ invalidate such permission if you have separately received it.
+
+ d) If the work has interactive user interfaces, each must display
+ Appropriate Legal Notices; however, if the Program has interactive
+ interfaces that do not display Appropriate Legal Notices, your
+ work need not make them do so.
+
+ A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit. Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+ 6. Conveying Non-Source Forms.
+
+ You may convey a covered work in object code form under the terms
+of sections 4 and 5, provided that you also convey the
+machine-readable Corresponding Source under the terms of this License,
+in one of these ways:
+
+ a) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by the
+ Corresponding Source fixed on a durable physical medium
+ customarily used for software interchange.
+
+ b) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by a
+ written offer, valid for at least three years and valid for as
+ long as you offer spare parts or customer support for that product
+ model, to give anyone who possesses the object code either (1) a
+ copy of the Corresponding Source for all the software in the
+ product that is covered by this License, on a durable physical
+ medium customarily used for software interchange, for a price no
+ more than your reasonable cost of physically performing this
+ conveying of source, or (2) access to copy the
+ Corresponding Source from a network server at no charge.
+
+ c) Convey individual copies of the object code with a copy of the
+ written offer to provide the Corresponding Source. This
+ alternative is allowed only occasionally and noncommercially, and
+ only if you received the object code with such an offer, in accord
+ with subsection 6b.
+
+ d) Convey the object code by offering access from a designated
+ place (gratis or for a charge), and offer equivalent access to the
+ Corresponding Source in the same way through the same place at no
+ further charge. You need not require recipients to copy the
+ Corresponding Source along with the object code. If the place to
+ copy the object code is a network server, the Corresponding Source
+ may be on a different server (operated by you or a third party)
+ that supports equivalent copying facilities, provided you maintain
+ clear directions next to the object code saying where to find the
+ Corresponding Source. Regardless of what server hosts the
+ Corresponding Source, you remain obligated to ensure that it is
+ available for as long as needed to satisfy these requirements.
+
+ e) Convey the object code using peer-to-peer transmission, provided
+ you inform other peers where the object code and Corresponding
+ Source of the work are being offered to the general public at no
+ charge under subsection 6d.
+
+ A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+ A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal, family,
+or household purposes, or (2) anything designed or sold for incorporation
+into a dwelling. In determining whether a product is a consumer product,
+doubtful cases shall be resolved in favor of coverage. For a particular
+product received by a particular user, "normally used" refers to a
+typical or common use of that class of product, regardless of the status
+of the particular user or of the way in which the particular user
+actually uses, or expects or is expected to use, the product. A product
+is a consumer product regardless of whether the product has substantial
+commercial, industrial or non-consumer uses, unless such uses represent
+the only significant mode of use of the product.
+
+ "Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to install
+and execute modified versions of a covered work in that User Product from
+a modified version of its Corresponding Source. The information must
+suffice to ensure that the continued functioning of the modified object
+code is in no case prevented or interfered with solely because
+modification has been made.
+
+ If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information. But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+ The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or updates
+for a work that has been modified or installed by the recipient, or for
+the User Product in which it has been modified or installed. Access to a
+network may be denied when the modification itself materially and
+adversely affects the operation of the network or violates the rules and
+protocols for communication across the network.
+
+ Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+ 7. Additional Terms.
+
+ "Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law. If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+ When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it. (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.) You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+ Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders of
+that material) supplement the terms of this License with terms:
+
+ a) Disclaiming warranty or limiting liability differently from the
+ terms of sections 15 and 16 of this License; or
+
+ b) Requiring preservation of specified reasonable legal notices or
+ author attributions in that material or in the Appropriate Legal
+ Notices displayed by works containing it; or
+
+ c) Prohibiting misrepresentation of the origin of that material, or
+ requiring that modified versions of such material be marked in
+ reasonable ways as different from the original version; or
+
+ d) Limiting the use for publicity purposes of names of licensors or
+ authors of the material; or
+
+ e) Declining to grant rights under trademark law for use of some
+ trade names, trademarks, or service marks; or
+
+ f) Requiring indemnification of licensors and authors of that
+ material by anyone who conveys the material (or modified versions of
+ it) with contractual assumptions of liability to the recipient, for
+ any liability that these contractual assumptions directly impose on
+ those licensors and authors.
+
+ All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10. If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term. If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+ If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+ Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions;
+the above requirements apply either way.
+
+ 8. Termination.
+
+ You may not propagate or modify a covered work except as expressly
+provided under this License. Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+ However, if you cease all violation of this License, then your
+license from a particular copyright holder is reinstated (a)
+provisionally, unless and until the copyright holder explicitly and
+finally terminates your license, and (b) permanently, if the copyright
+holder fails to notify you of the violation by some reasonable means
+prior to 60 days after the cessation.
+
+ Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+ Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License. If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+ 9. Acceptance Not Required for Having Copies.
+
+ You are not required to accept this License in order to receive or
+run a copy of the Program. Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance. However,
+nothing other than this License grants you permission to propagate or
+modify any covered work. These actions infringe copyright if you do
+not accept this License. Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+ 10. Automatic Licensing of Downstream Recipients.
+
+ Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License. You are not responsible
+for enforcing compliance by third parties with this License.
+
+ An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations. If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+ You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License. For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+ 11. Patents.
+
+ A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based. The
+work thus licensed is called the contributor's "contributor version".
+
+ A contributor's "essential patent claims" are all patent claims
+owned or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version. For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+ Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+ In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement). To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+ If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients. "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+ If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+ A patent license is "discriminatory" if it does not include within
+the scope of its coverage, prohibits the exercise of, or is
+conditioned on the non-exercise of one or more of the rights that are
+specifically granted under this License. You may not convey a covered
+work if you are a party to an arrangement with a third party that is
+in the business of distributing software, under which you make payment
+to the third party based on the extent of your activity of conveying
+the work, and under which the third party grants, to any of the
+parties who would receive the covered work from you, a discriminatory
+patent license (a) in connection with copies of the covered work
+conveyed by you (or copies made from those copies), or (b) primarily
+for and in connection with specific products or compilations that
+contain the covered work, unless you entered into that arrangement,
+or that patent license was granted, prior to 28 March 2007.
+
+ Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+ 12. No Surrender of Others' Freedom.
+
+ If conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot convey a
+covered work so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you may
+not convey it at all. For example, if you agree to terms that obligate you
+to collect a royalty for further conveying from those to whom you convey
+the Program, the only way you could satisfy both those terms and this
+License would be to refrain entirely from conveying the Program.
+
+ 13. Use with the GNU Affero General Public License.
+
+ Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU Affero General Public License into a single
+combined work, and to convey the resulting work. The terms of this
+License will continue to apply to the part which is the covered work,
+but the special requirements of the GNU Affero General Public License,
+section 13, concerning interaction through a network will apply to the
+combination as such.
+
+ 14. Revised Versions of this License.
+
+ The Free Software Foundation may publish revised and/or new versions of
+the GNU General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+ Each version is given a distinguishing version number. If the
+Program specifies that a certain numbered version of the GNU General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation. If the Program does not specify a version number of the
+GNU General Public License, you may choose any version ever published
+by the Free Software Foundation.
+
+ If the Program specifies that a proxy can decide which future
+versions of the GNU General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+ Later license versions may give you additional or different
+permissions. However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+ 15. Disclaimer of Warranty.
+
+ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+ 16. Limitation of Liability.
+
+ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+ 17. Interpretation of Sections 15 and 16.
+
+ If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+state the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+
+ Copyright (C)
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see .
+
+Also add information on how to contact you by electronic and paper mail.
+
+ If the program does terminal interaction, make it output a short
+notice like this when it starts in an interactive mode:
+
+ Copyright (C)
+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License. Of course, your program's commands
+might be different; for a GUI interface, you would use an "about box".
+
+ You should also get your employer (if you work as a programmer) or school,
+if any, to sign a "copyright disclaimer" for the program, if necessary.
+For more information on this, and how to apply and follow the GNU GPL, see
+.
+
+ The GNU General Public License does not permit incorporating your program
+into proprietary programs. If your program is a subroutine library, you
+may consider it more useful to permit linking proprietary applications with
+the library. If this is what you want to do, use the GNU Lesser General
+Public License instead of this License. But first, please read
+.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/cmd/Main.hs b/cmd/Main.hs
new file mode 100644
--- /dev/null
+++ b/cmd/Main.hs
@@ -0,0 +1,33 @@
+-- This file is part of hwormhole.
+
+-- hwormhole is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+
+-- hwormhole is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+-- GNU General Public License for more details.
+
+-- You should have received a copy of the GNU General Public License
+-- along with hwormhole. If not, see .
+
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import Protolude
+
+import qualified Data.Text.IO as TIO
+import qualified Transit
+
+import Options
+
+main :: IO ()
+main = do
+ env <- Transit.prepareAppEnv appid "wordlist.txt" =<< commandlineParser
+ result <- Transit.runApp Transit.app env
+ either (TIO.putStrLn . show) return result
+ where
+ appid = "lothar.com/wormhole/text-or-file-xfer"
diff --git a/cmd/Options.hs b/cmd/Options.hs
new file mode 100644
--- /dev/null
+++ b/cmd/Options.hs
@@ -0,0 +1,76 @@
+-- This file is part of hwormhole.
+
+-- hwormhole is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+
+-- hwormhole is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+-- GNU General Public License for more details.
+
+-- You should have received a copy of the GNU General Public License
+-- along with hwormhole. If not, see .
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Options
+ ( commandlineParser
+ )
+where
+
+import Protolude
+
+import qualified Options.Applicative as Opt
+
+import qualified Transit
+
+optionsParser :: Opt.Parser Transit.Options
+optionsParser
+ = Transit.Options
+ <$> commandParser
+ <*> Opt.option
+ (Opt.maybeReader Transit.parseWebSocketEndpoint)
+ ( Opt.long "relayserver-url" <>
+ Opt.help "Endpoint for the Relay server" <>
+ Opt.value defaultEndpoint <>
+ Opt.showDefault )
+ <*> Opt.option
+ (Opt.maybeReader Transit.parseTransitRelayUri)
+ ( Opt.long "transit-helper" <>
+ Opt.help "Transit relay to use" <>
+ Opt.value defaultTransitUrl <>
+ Opt.showDefault )
+ where
+ -- | Default URL for relay server.
+ --
+ -- This is a relay server run by Brian Warner.
+ defaultEndpoint = fromMaybe (panic "Invalid default URL") (Transit.parseWebSocketEndpoint "ws://relay.magic-wormhole.io:4000/v1")
+ -- | Default Transit Relay Url
+ --
+ -- This is a Transit relay run by Brian Warner.
+ defaultTransitUrl = fromMaybe (panic "Invalid transit relay URL") (Transit.parseTransitRelayUri "tcp:transit.magic-wormhole.io:4001")
+
+commandParser :: Opt.Parser Transit.Command
+commandParser = Opt.hsubparser (sendCommand <> receiveCommand)
+ where
+ sendCommand = Opt.command "send" (Opt.info sendOptions (Opt.progDesc "send a text message, a file or a directory"))
+ receiveCommand = Opt.command "receive" (Opt.info receiveOptions (Opt.progDesc "receive a text message"))
+ receiveOptions :: Opt.Parser Transit.Command
+ receiveOptions = Transit.Receive <$> optional (Opt.strArgument (Opt.metavar "CODE"))
+ sendOptions :: Opt.Parser Transit.Command
+ sendOptions = Transit.Send <$> parseMessageType
+ parseMessageType :: Opt.Parser Transit.MessageType
+ parseMessageType = msgParser <|> fileOrDirParser
+ msgParser :: Opt.Parser Transit.MessageType
+ msgParser = Transit.TMsg <$> Opt.strOption (Opt.long "text" <> Opt.help "Text message to send")
+ fileOrDirParser :: Opt.Parser Transit.MessageType
+ fileOrDirParser = Transit.TFile <$> Opt.strArgument (Opt.metavar "FILENAME" <> Opt.help "file path")
+
+opts :: Opt.ParserInfo Transit.Options
+opts = Opt.info (Opt.helper <*> optionsParser) (Opt.fullDesc <> Opt.header "wormhole")
+
+commandlineParser :: IO Transit.Options
+commandlineParser = Opt.execParser opts
diff --git a/hwormhole.cabal b/hwormhole.cabal
new file mode 100644
--- /dev/null
+++ b/hwormhole.cabal
@@ -0,0 +1,113 @@
+-- Initial haskell-magic-wormhole-client.cabal generated by cabal init.
+-- For further documentation, see http://haskell.org/cabal/users-guide/
+
+name: hwormhole
+version: 0.1.0.0
+synopsis: magic-wormhole client
+description: A secure way to send files over the Internet using the magic-wormhole protocol
+license: GPL-3
+license-file: LICENSE
+author: Ramakrishnan Muthukrishnan
+maintainer: ram@leastauthority.com
+copyright: (c) 2018 Least Authority TFA Gmbh
+category: Network
+build-type: Simple
+extra-source-files: ChangeLog.md
+cabal-version: 1.24
+data-files: wordlist.txt
+
+source-repository head
+ type: git
+ location: https://github.com/LeastAuthority/wormhole-client
+
+library
+ hs-source-dirs: src
+ exposed-modules: Transit
+ , Transit.Internal.App
+ , Transit.Internal.Conf
+ , Transit.Internal.Errors
+ , Transit.Internal.FileTransfer
+ , Transit.Internal.Network
+ , Transit.Internal.Peer
+ , Transit.Internal.Messages
+ , Transit.Internal.Pipeline
+ , Transit.Internal.Crypto
+ build-depends: aeson >= 1.4 && < 2
+ , async >= 2.1.0 && < 3.0
+ , base >= 4.6 && < 5
+ , binary >= 0.7 && < 1.0
+ , bytestring >= 0.9 && < 1.0
+ , conduit >= 1.2.13 && < 2.0
+ , conduit-extra > 1.0.0 && < 2.0
+ , containers >= 0.5.10 && < 1.0
+ , cryptonite >= 0.24 && < 1.0
+ , directory >= 1.3 && < 2.0
+ , filepath >= 1.4.0 && < 2.0
+ , haskeline >= 0.7.4 && < 1.0
+ , hex >= 0.1.2 && < 1.0
+ , magic-wormhole >= 0.2.1 && < 1.0
+ , memory >= 0.14.15 && < 1.0
+ , mtl >= 2.2.2 && < 3.0
+ , network >= 2.7 && < 3
+ , network-info >= 0.2.0 && < 1.0
+ , pathwalk >= 0.3.1.2 && < 1.0
+ , protolude >= 0.2.1 && < 1.0
+ , random >= 1.1 && < 2.0
+ , saltine == 0.1.0.1 && < 1.0
+ , spake2 >= 0.4 && < 1.0
+ , temporary >= 1.3 && < 2.0
+ , text >= 1.2.1 && < 2.0
+ , transformers >= 0.5.5 && < 1.0
+ , unix-compat >= 0.5.0 && < 1.0
+ , zip >= 1.2.0 && < 2.0
+ other-modules: Paths_hwormhole
+ default-language: Haskell2010
+ default-extensions: NoImplicitPrelude OverloadedStrings TypeApplications
+ ghc-options: -Wall -Werror=incomplete-patterns
+
+executable hwormhole-exe
+ main-is: Main.hs
+ other-modules: Options
+ -- other-extensions:
+ build-depends: base >=4.6 && <5
+ , bytestring
+ , aeson >=1.4 && <2
+ , binary
+ , hwormhole
+ , optparse-applicative
+ , protolude
+ , text
+ , transformers
+ hs-source-dirs: cmd
+ default-language: Haskell2010
+ default-extensions: NoImplicitPrelude OverloadedStrings TypeApplications
+ ghc-options: -Wall -Werror=incomplete-patterns
+
+test-suite hwormhole-tests
+ type: exitcode-stdio-1.0
+ main-is: Main.hs
+ hs-source-dirs: tests
+ default-extensions: NoImplicitPrelude OverloadedStrings TypeApplications
+ ghc-options: -Wall -Werror=incomplete-patterns
+ build-depends: base >=4.6 && <5
+ , bytestring
+ , aeson >=1.4 && <2
+ , bytestring
+ , conduit
+ , containers
+ , binary
+ , binary-conduit
+ , conduit-extra
+ , text
+ , protolude
+ , hspec
+ , saltine
+ , hwormhole
+ , magic-wormhole
+ , hedgehog
+ other-modules: ProtocolTests
+ , MessagesTests
+ , PipelineTests
+ , CryptoTests
+ , Generator
+ default-language: Haskell2010
diff --git a/src/Transit.hs b/src/Transit.hs
new file mode 100644
--- /dev/null
+++ b/src/Transit.hs
@@ -0,0 +1,40 @@
+-- |
+-- Description : A Magic Wormhole library that supports file and directory transfer.
+--
+-- Magic Wormhole is a technology for getting things from one computer to another, safely.
+--
+-- To use it, you must use the MagicWormhole library to first establish an encrypted connection:
+--
+-- 1. Start a 'Rendezvous.Session' with the Rendezvous server, to allow peers to find each other ('Rendezvous.runClient')
+-- 2. Negotiate a shared 'Messages.Nameplate' so peers can find each other on the server ('Rendezvous.allocate', 'Rendezvous.list')
+-- 3. Use the shared 'Messages.Nameplate' to 'Rendezvous.open' a shared 'Messages.Mailbox'
+-- 4. Use a secret password shared between peers to establish an encrypted connection ('Peer.withEncryptedConnection')
+--
+-- Once you've done this, you can communicate with your peer via 'Transit.send' and 'Transit.receive'.
+-- Once can send and receive either Text messages or Files.
+--
+-- The password is never sent over the wire.
+-- Rather, it is used to negotiate a session key using SPAKE2,
+-- and that key itself is used to derive many per-message keys,
+-- so that each message is encrypted using NaCl SecretBox.
+--
+module Transit
+ ( App.Env(..)
+ , App.prepareAppEnv
+ , App.app
+ , App.runApp
+ , Conf.Options(..)
+ , Conf.Command(..)
+ , Errors.Error(..)
+ , FileTransfer.MessageType(..)
+ , MagicWormhole.parseWebSocketEndpoint
+ , Network.parseTransitRelayUri
+ )
+where
+
+import qualified Transit.Internal.FileTransfer as FileTransfer
+import qualified Transit.Internal.Network as Network
+import qualified Transit.Internal.Errors as Errors
+import qualified Transit.Internal.Conf as Conf
+import qualified Transit.Internal.App as App
+import qualified MagicWormhole
diff --git a/src/Transit/Internal/App.hs b/src/Transit/Internal/App.hs
new file mode 100644
--- /dev/null
+++ b/src/Transit/Internal/App.hs
@@ -0,0 +1,238 @@
+-- | Description: a file transfer monad transformer
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Transit.Internal.App
+ ( Env(..)
+ , prepareAppEnv
+ , app
+ , runApp
+ )
+where
+
+import Protolude
+
+import qualified Data.Text as Text
+import qualified Data.Text.IO as TIO
+import qualified MagicWormhole
+import qualified System.Console.Haskeline as H
+import qualified System.Console.Haskeline.Completion as HC
+import qualified Crypto.Spake2 as Spake2
+
+import System.IO.Error (IOError)
+import System.Random (randomR, getStdGen)
+import Data.String (String)
+import Control.Monad.Trans.Except (ExceptT(..))
+import Control.Monad.Except (liftEither)
+
+import Transit.Internal.Conf (Options(..), Command(..))
+import Transit.Internal.Errors (Error(..), CommunicationError(..))
+import Transit.Internal.FileTransfer(MessageType(..), sendFile, receiveFile)
+import Transit.Internal.Peer (sendOffer, receiveOffer, receiveMessageAck, sendMessageAck, decodeTransitMsg)
+import Paths_hwormhole
+
+type Password = ByteString
+
+-- | Magic Wormhole transit app environment
+data Env
+ = Env { appID :: MagicWormhole.AppID
+ -- ^ Application specific ID
+ , side :: MagicWormhole.Side
+ -- ^ random 5-byte bytestring
+ , config :: Options
+ -- ^ configuration like relay and transit url
+ , wordList :: [(Text, Text)]
+ -- ^ pass code word list (list of pair of words)
+ }
+
+-- | genWordlist would produce a list of the form
+-- [ ("aardwark", "adroitness"),
+-- ("absurd", "adviser"),
+-- ....
+-- ("zulu", "yucatan") ]
+genWordList :: FilePath -> IO [(Text, Text)]
+genWordList wordlistFile = do
+ file <- TIO.readFile wordlistFile
+ let contents = map toWordPair $ Text.lines file
+ return contents
+ where
+ toWordPair :: Text -> (Text, Text)
+ toWordPair line =
+ let ws = map Text.toLower $ Text.words line
+ Just firstWord = atMay ws 1
+ Just sndWord = atMay ws 2
+ in (firstWord, sndWord)
+
+
+-- | Create an 'Env', given the AppID, wordlist file and 'Options'
+prepareAppEnv :: Text -> FilePath -> Options -> IO Env
+prepareAppEnv appid wordlistPath options = do
+ side' <- MagicWormhole.generateSide
+ wordlist <- genWordList =<< getDataFileName wordlistPath
+ let appID' = MagicWormhole.AppID appid
+ return $ Env appID' side' options wordlist
+
+allocatePassword :: [(Text, Text)] -> IO Text
+allocatePassword wordlist = do
+ g <- getStdGen
+ let (r1, g') = randomR (0, 255) g
+ (r2, _) = randomR (0, 255) g'
+ Just evenW = fst <$> atMay wordlist r2
+ Just oddW = snd <$> atMay wordlist r1
+ return $ Text.concat [oddW, "-", evenW]
+
+genPasscodes :: [Text] -> [(Text, Text)] -> [Text]
+genPasscodes nameplates wordpairs =
+ let evens = map fst wordpairs
+ odds = map snd wordpairs
+ wordCombos = [ o <> "-" <> e | o <- odds, e <- evens ]
+ in
+ [ n <> "-" <> hiphenWord | n <- nameplates, hiphenWord <- wordCombos ]
+
+printSendHelpText :: Text -> IO ()
+printSendHelpText passcode = do
+ TIO.putStrLn $ "Wormhole code is: " <> passcode
+ TIO.putStrLn "On the other computer, please run:"
+ TIO.putStrLn ""
+ TIO.putStrLn $ "wormhole receive " <> passcode
+
+completeWord :: MonadIO m => [Text] -> HC.CompletionFunc m
+completeWord wordlist = HC.completeWord Nothing "" completionFunc
+ where
+ completionFunc :: Monad m => String -> m [HC.Completion]
+ completionFunc word = do
+ let completions = filter (toS word `Text.isPrefixOf`) wordlist
+ return $ map (HC.simpleCompletion . toS) completions
+
+-- | Take an input code from the user with code completion.
+-- In order for the code completion to work, we need to find
+-- the possible open nameplates, the possible words and then
+-- do the completion as the user types the code.
+-- TODO: This function does too much. Perfect target for refactoring.
+getCode :: MagicWormhole.Session -> [(Text, Text)] -> IO Text
+getCode session wordlist = do
+ nameplates <- MagicWormhole.list session
+ let ns = [ n | MagicWormhole.Nameplate n <- nameplates ]
+ putText "Enter the receive wormhole code: "
+ H.runInputT (settings (genPasscodes ns wordlist)) getInput
+ where
+ settings :: MonadIO m => [Text] -> H.Settings m
+ settings possibleWords = H.Settings
+ { H.complete = completeWord possibleWords
+ , H.historyFile = Nothing
+ , H.autoAddHistory = False
+ }
+ getInput :: H.InputT IO Text
+ getInput = do
+ minput <- H.getInputLine ""
+ case minput of
+ Nothing -> return ""
+ Just input -> return (toS input)
+
+-- | App Monad Transformer that reads the configuration from 'Env', runs
+-- a computation over the IO Monad and returns either the value 'a' or 'Error'
+newtype App a = App {
+ getApp :: ReaderT Env (ExceptT Error IO) a
+ } deriving (Functor, Applicative, Monad, MonadIO, MonadReader Env, MonadError Error)
+
+-- | run the App Monad Transformer
+runApp :: App a -> Env -> IO (Either Error a)
+runApp appM env = runExceptT (runReaderT (getApp appM) env)
+
+-- | Given the magic-wormhole session, appid, password, a function to print a helpful message
+-- on the command the receiver needs to type (simplest would be just a `putStrLn`) and the
+-- path on the disk of the sender of the file that needs to be sent, `sendFile` sends it via
+-- the wormhole securely. The receiver, on successfully receiving the file, would compute
+-- a sha256 sum of the encrypted file and sends it across to the sender, along with an
+-- acknowledgement, which the sender can verify.
+send :: MagicWormhole.Session -> Password -> MessageType -> App ()
+send session password tfd = do
+ env <- ask
+ -- first establish a wormhole session with the receiver and
+ -- then talk the filetransfer protocol over it as follows.
+ let options = config env
+ let appid = appID env
+ let transitserver = transitUrl options
+ nameplate <- liftIO $ MagicWormhole.allocate session
+ mailbox <- liftIO $ MagicWormhole.claim session nameplate
+ peer <- liftIO $ MagicWormhole.open session mailbox -- XXX: We should run `close` in the case of exceptions?
+ let (MagicWormhole.Nameplate n) = nameplate
+ liftIO $ printSendHelpText $ toS n <> "-" <> toS password
+ result <- liftIO $ MagicWormhole.withEncryptedConnection peer (Spake2.makePassword (toS n <> "-" <> password))
+ (\conn ->
+ case tfd of
+ TMsg msg -> do
+ let offer = MagicWormhole.Message msg
+ sendOffer conn offer
+ -- wait for "answer" message with "message_ack" key
+ first NetworkError <$> receiveMessageAck conn
+ TFile filepath ->
+ sendFile conn transitserver appid filepath
+ )
+ liftEither result
+
+-- | receive a text message or file from the wormhole peer.
+receive :: MagicWormhole.Session -> Text -> App ()
+receive session code = do
+ env <- ask
+ -- establish the connection
+ let options = config env
+ let appid = appID env
+ let transitserver = transitUrl options
+ let codeSplit = Text.split (=='-') code
+ let (Just nameplate) = headMay codeSplit
+ mailbox <- liftIO $ MagicWormhole.claim session (MagicWormhole.Nameplate nameplate)
+ peer <- liftIO $ MagicWormhole.open session mailbox
+ result <- liftIO $ MagicWormhole.withEncryptedConnection peer (Spake2.makePassword (toS (Text.strip code)))
+ (\conn -> do
+ -- unfortunately, the receiver has no idea which message to expect.
+ -- If the sender is only sending a text message, it gets an offer first.
+ -- if the sender is sending a file/directory, then transit comes first
+ -- and then offer comes in. `Transit.receiveOffer' will attempt to interpret
+ -- the bytestring as an offer message. If that fails, it passes the raw bytestring
+ -- as a Left value so that we can try to decode it as a TransitMsg.
+ someOffer <- receiveOffer conn
+ case someOffer of
+ Right (MagicWormhole.Message message) -> do
+ TIO.putStrLn message
+ result <- try (sendMessageAck conn "ok") :: IO (Either IOError ())
+ return $ bimap (const (NetworkError (ConnectionError "sending the ack message failed"))) identity result
+ Right (MagicWormhole.File _ _) -> do
+ sendMessageAck conn "not_ok"
+ return $ Left (NetworkError (ConnectionError "did not expect a file offer"))
+ Right MagicWormhole.Directory {} ->
+ return $ Left (NetworkError (UnknownPeerMessage "directory offer is not supported"))
+ -- ok, we received the Transit Message, send back a transit message
+ Left received ->
+ case decodeTransitMsg (toS received) of
+ Left e -> return $ Left (NetworkError e)
+ Right transitMsg ->
+ receiveFile conn transitserver appid transitMsg
+ )
+ liftEither result
+
+-- | A file transfer application that takes an 'Env' and depending on the
+-- config options, either sends or receives a file, directory or a text
+-- message from the peer.
+app :: App ()
+app = do
+ env <- ask
+ let options = config env
+ endpoint = relayEndpoint options
+ case cmd options of
+ Send tfd ->
+ liftIO (MagicWormhole.runClient endpoint (appID env) (side env) $ \session ->
+ runApp (sendSession tfd session) env) >>= liftEither
+ Receive maybeCode ->
+ liftIO (MagicWormhole.runClient endpoint (appID env) (side env) $ \session ->
+ runApp (receiveSession maybeCode session) env) >>= liftEither
+ where
+ getWormholeCode :: MagicWormhole.Session -> [(Text, Text)] -> Maybe Text -> IO Text
+ getWormholeCode session wordlist Nothing = getCode session wordlist
+ getWormholeCode _ _ (Just code) = return code
+ sendSession offerMsg session = do
+ env <- ask
+ password <- liftIO $ allocatePassword (wordList env)
+ send session (toS password) offerMsg
+ receiveSession code session = do
+ env <- ask
+ maybeCode <- liftIO $ getWormholeCode session (wordList env) code
+ receive session maybeCode
diff --git a/src/Transit/Internal/Conf.hs b/src/Transit/Internal/Conf.hs
new file mode 100644
--- /dev/null
+++ b/src/Transit/Internal/Conf.hs
@@ -0,0 +1,32 @@
+-- | Description: Application Configuration
+module Transit.Internal.Conf
+ ( Options(..)
+ , Command(..)
+ )
+where
+
+import Protolude
+
+import qualified MagicWormhole
+
+import Transit.Internal.Network (RelayEndpoint)
+import Transit.Internal.FileTransfer (MessageType)
+
+-- | Application Configuration options
+data Options
+ = Options
+ { cmd :: Command
+ -- ^ send or receive
+ , relayEndpoint :: MagicWormhole.WebSocketEndpoint
+ -- ^ Rendezvous server websocket endpoint URL
+ , transitUrl :: RelayEndpoint
+ -- ^ Transit Relay URL
+ } deriving (Eq, Show)
+
+-- | Commands
+data Command
+ = Send MessageType
+ -- ^ Send a file, directory or a text message
+ | Receive (Maybe Text)
+ -- ^ Receive a file, directory or a text message
+ deriving (Eq, Show)
diff --git a/src/Transit/Internal/Crypto.hs b/src/Transit/Internal/Crypto.hs
new file mode 100644
--- /dev/null
+++ b/src/Transit/Internal/Crypto.hs
@@ -0,0 +1,105 @@
+-- | Description: functions and types that deal with Cryptography
+module Transit.Internal.Crypto
+ ( encrypt
+ , decrypt
+ , PlainText(..)
+ , CipherText(..)
+ , deriveKeyFromPurpose
+ , Purpose(..)
+ , CryptoError(..)
+ )
+where
+
+import Protolude
+
+import qualified Control.Exception as E
+import qualified Data.ByteString as BS
+import qualified Crypto.Saltine.Class as Saltine
+import qualified Crypto.Saltine.Core.SecretBox as SecretBox
+import Crypto.Saltine.Internal.ByteSizes (boxNonce)
+import qualified Crypto.KDF.HKDF as HKDF
+import Crypto.Hash (SHA256(..))
+import qualified Crypto.Saltine.Internal.ByteSizes as ByteSizes
+
+-- | Type for representing unencrypted plain text
+newtype PlainText = PlainText ByteString
+ deriving (Eq, Show)
+
+-- | Type for representing encrypted cipher text.
+newtype CipherText = CipherText ByteString
+ deriving (Eq)
+
+-- | Error Type for exceptions thrown by the Crypto module
+data CryptoError = BadNonce Text
+ -- ^ The nonce value in the received message is invalid.
+ | CouldNotDecrypt Text
+ -- ^ We could not decrypt the incoming encrypted record.
+ | KeyGenError Text
+ -- ^ Could not generate transit keys.
+ deriving (Eq, Show)
+
+instance E.Exception CryptoError
+
+-- | decrypt the bytestring representing ciphertext block with
+-- the given key. It is assumed that the ciphertext bytestring
+-- is nonce followed by the actual encrypted data.
+decrypt :: SecretBox.Key -> CipherText -> Either CryptoError (PlainText, SecretBox.Nonce)
+decrypt key (CipherText ciphertext) =
+ -- extract nonce from ciphertext.
+ let (nonceBytes, record) = BS.splitAt boxNonce ciphertext
+ maybeResult = Saltine.decode nonceBytes >>=
+ \nonce -> SecretBox.secretboxOpen key nonce record >>=
+ \plaintext -> return (plaintext, nonce)
+ in
+ case maybeResult of
+ Just (plaintext, nonce) -> Right (PlainText plaintext, nonce)
+ Nothing -> Left (CouldNotDecrypt "SecretBox failed to open")
+
+-- | encrypt the given chunk with the given secretbox key and nonce.
+-- Saltine's nonce seem represented as a big endian bytestring.
+-- However, to interop with the wormhole python client, we need to
+-- use and send nonce as a little endian bytestring.
+encrypt :: SecretBox.Key -> SecretBox.Nonce -> PlainText -> Either CryptoError CipherText
+encrypt key nonce (PlainText plaintext) =
+ let nonceLE = BS.reverse $ toS $ Saltine.encode nonce
+ maybeResult = Saltine.decode (toS nonceLE) >>=
+ \newNonce -> Just (toS (SecretBox.secretbox key newNonce plaintext))
+ in
+ case maybeResult of
+ Just ciphertext -> Right (CipherText (nonceLE <> ciphertext))
+ Nothing -> Left (BadNonce "encrypt: could not decode nonce")
+
+hkdf :: ByteString -> SecretBox.Key -> ByteString -> ByteString
+hkdf salt key purpose =
+ HKDF.expand (HKDF.extract salt (Saltine.encode key) :: HKDF.PRK SHA256) purpose keySize
+ where
+ keySize = ByteSizes.secretBoxKey
+
+-- | Various purpose types for key derivation.
+--
+-- Normally used with 'deriveKeyFromPurpose'.
+data Purpose
+ = SenderHandshake
+ -- ^ Purpose type to be used by transit sender.
+ | ReceiverHandshake
+ -- ^ Purpose type to be used by transit receiver.
+ | SenderRecord
+ -- ^ Purpose type to be used for encrypting records.
+ | ReceiverRecord
+ -- ^ Purpose type to be used for decrypting records.
+ | RelayHandshake
+ -- ^ Purpose type to be used for transit relay handshake.
+ deriving (Eq, Show)
+
+-- | derive a new purpose-specific key from a master key.
+deriveKeyFromPurpose :: Purpose -> SecretBox.Key -> ByteString
+deriveKeyFromPurpose purpose key =
+ hkdf salt key (purposeStr purpose)
+ where
+ salt = "" :: ByteString
+ purposeStr :: Purpose -> ByteString
+ purposeStr SenderHandshake = "transit_sender"
+ purposeStr ReceiverHandshake = "transit_receiver"
+ purposeStr SenderRecord = "transit_record_sender_key"
+ purposeStr ReceiverRecord = "transit_record_receiver_key"
+ purposeStr RelayHandshake = "transit_relay_token"
diff --git a/src/Transit/Internal/Errors.hs b/src/Transit/Internal/Errors.hs
new file mode 100644
--- /dev/null
+++ b/src/Transit/Internal/Errors.hs
@@ -0,0 +1,25 @@
+-- | Description: Module for representing Error types
+module Transit.Internal.Errors
+ ( -- * Error
+ Error(..)
+ , N.CommunicationError(..)
+ , P.InvalidHandshake
+ , C.CryptoError
+ )
+where
+
+import Protolude
+
+import qualified Control.Exception as E
+
+import qualified Transit.Internal.Network as N
+import qualified Transit.Internal.Crypto as C
+import qualified Transit.Internal.Peer as P
+
+-- | An Error type for the Magic Wormhole Transit Module
+data Error = CipherError C.CryptoError
+ | NetworkError N.CommunicationError
+ | HandshakeError P.InvalidHandshake
+ deriving (Show)
+
+instance E.Exception Error
diff --git a/src/Transit/Internal/FileTransfer.hs b/src/Transit/Internal/FileTransfer.hs
new file mode 100644
--- /dev/null
+++ b/src/Transit/Internal/FileTransfer.hs
@@ -0,0 +1,235 @@
+-- | Description: Functions for sending and receiving files/directories
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Transit.Internal.FileTransfer
+ ( sendFile
+ , receiveFile
+ , MessageType(..)
+ )
+where
+
+import Protolude
+
+import qualified Data.Aeson as Aeson
+import qualified Conduit as C
+import qualified Data.Set as Set
+import qualified Data.ByteString.Lazy as BL
+
+import Network.Socket (socketPort, Socket)
+import System.FilePath (())
+import System.Directory (removeFile, getTemporaryDirectory)
+import System.IO.Temp (createTempDirectory)
+
+import qualified MagicWormhole
+
+import Transit.Internal.Errors (Error(..))
+import Transit.Internal.Crypto (CipherText(..))
+import Transit.Internal.Network
+ ( tcpListener
+ , buildHints
+ , buildRelayHints
+ , startServer
+ , startClient
+ , closeConnection
+ , RelayEndpoint
+ , CommunicationError(..)
+ , TransitEndpoint(..))
+
+import Transit.Internal.Peer
+ ( makeRecordKeys
+ , senderHandshakeExchange
+ , senderTransitExchange
+ , senderOfferExchange
+ , receiveWormholeMessage
+ , sendTransitMsg
+ , sendWormholeMessage
+ , receiverHandshakeExchange
+ , makeAckMessage
+ , generateTransitSide
+ , sendRecord
+ , receiveRecord
+ , unzipInto)
+
+import Transit.Internal.Messages
+ ( TransitMsg( Transit, Answer )
+ , Ability(..)
+ , AbilityV1(..)
+ , Ack( FileAck )
+ , TransitAck (..))
+
+import Transit.Internal.Pipeline
+ ( sendPipeline
+ , receivePipeline)
+
+-- | Transfer type
+data MessageType
+ = TMsg Text
+ -- ^ Text message transfer
+ | TFile FilePath
+ -- ^ File or Directory transfer
+ deriving (Show, Eq)
+
+transitPurpose :: MagicWormhole.AppID -> ByteString
+transitPurpose (MagicWormhole.AppID appID) = toS appID <> "/transit-key"
+
+sendAckMessage :: TransitEndpoint -> ByteString -> IO (Either Error ())
+sendAckMessage (TransitEndpoint ep _ key) sha256Sum = do
+ let ackMessage = makeAckMessage key sha256Sum
+ case ackMessage of
+ Right (CipherText encMsg) -> do
+ res <- sendRecord ep encMsg
+ return $ bimap NetworkError (const ()) res
+ Left e -> return $ Left (CipherError e)
+
+receiveAckMessage :: TransitEndpoint -> IO (Either Error Text)
+receiveAckMessage (TransitEndpoint ep _ key) = do
+ ackBytes <- (fmap . fmap) BL.fromStrict (receiveRecord ep key)
+ case ackBytes of
+ Left e -> return $ Left (CipherError e)
+ Right ack' ->
+ case Aeson.eitherDecode ack' of
+ Right (TransitAck msg checksum) | msg == "ok" -> return (Right checksum)
+ | otherwise -> return $ Left (NetworkError (TransitError "transit ack failure"))
+ Left s -> return $ Left (NetworkError (TransitError (toS ("transit ack failure: " <> s))))
+
+establishSenderTransit :: MagicWormhole.EncryptedConnection -> RelayEndpoint -> MagicWormhole.AppID -> IO (Either Error TransitEndpoint)
+establishSenderTransit conn transitserver appid = do
+ -- exchange abilities
+ sock' <- tcpListener
+ portnum <- socketPort sock'
+ side <- generateTransitSide
+ ourHints <- buildHints portnum transitserver
+ let ourRelayHints = buildRelayHints transitserver
+ transitResp <- senderTransitExchange conn (Set.toList ourHints)
+ case transitResp of
+ Left s -> return $ Left (NetworkError s)
+ Right (Transit _peerAbilities peerHints) -> do
+ -- combine our relay hints with peer's direct and relay hints
+ let allHints = Set.toList $ ourRelayHints <> peerHints
+ -- concurrently start client and server
+ transitEndpoint <- race (startServer sock') (startClient allHints)
+ let ep = either identity identity transitEndpoint
+ case ep of
+ Left e -> return (Left (NetworkError e))
+ Right endpoint -> do
+ -- 0. derive transit key
+ let transitKey = MagicWormhole.deriveKey conn (transitPurpose appid)
+ -- 1. create record keys
+ recordKeys = makeRecordKeys transitKey
+ case recordKeys of
+ Left e -> return (Left (CipherError e))
+ Right (sRecordKey, rRecordKey) -> do
+ -- 2. handshakeExchange
+ handshake <- senderHandshakeExchange endpoint transitKey side
+ -- if handshakeExchange is successful, return the TCPEndpoint
+ -- as, we now have a "secure" socket to communicate.
+ case handshake of
+ Left e -> return (Left (HandshakeError e))
+ Right _ -> return $ Right (TransitEndpoint endpoint sRecordKey rRecordKey)
+ Right _ -> return $ Left (NetworkError (UnknownPeerMessage "Could not decode message"))
+
+establishReceiverTransit :: MagicWormhole.EncryptedConnection -> RelayEndpoint -> MagicWormhole.AppID -> TransitMsg -> Socket -> IO (Either Error TransitEndpoint)
+establishReceiverTransit conn transitserver appid (Transit _peerAbilities peerHints) socket = do
+ let ourRelayHints = buildRelayHints transitserver
+ side <- generateTransitSide
+ -- combine our relay hints with peer's direct and relay hints
+ let allHints = Set.toList (peerHints <> ourRelayHints)
+ -- derive transit key
+ let transitKey = MagicWormhole.deriveKey conn (transitPurpose appid)
+ transitEndpoint <- race (startServer socket) (startClient allHints)
+ let ep = either identity identity transitEndpoint
+ case ep of
+ Left e -> return (Left (NetworkError e))
+ Right endpoint -> do
+ -- create sender/receiver record key, sender record key
+ -- for decrypting incoming records, receiver record key
+ -- for sending the file_ack back at the end.
+ let recordKeys = makeRecordKeys transitKey
+ case recordKeys of
+ Left e -> return $ Left (CipherError e)
+ Right (sRecordKey, rRecordKey) -> do
+ -- handshakeExchange
+ handshake <- receiverHandshakeExchange endpoint transitKey side
+ case handshake of
+ Left e -> return (Left (HandshakeError e))
+ Right _ -> return $ Right (TransitEndpoint endpoint sRecordKey rRecordKey)
+establishReceiverTransit _ _ _ _ _ = return $ Left (NetworkError (UnknownPeerMessage "Could not recognize the message"))
+
+-- | Given the magic-wormhole session, appid, password, a function to print a helpful message
+-- on the command the receiver needs to type (simplest would be just a `putStrLn`) and the
+-- path on the disk of the sender of the file that needs to be sent, `sendFile` sends it via
+-- the wormhole securely. The receiver, on successfully receiving the file, would compute
+-- a sha256 sum of the encrypted file and sends it across to the sender, along with an
+-- acknowledgement, which the sender can verify.
+sendFile :: MagicWormhole.EncryptedConnection -> RelayEndpoint -> MagicWormhole.AppID -> FilePath -> IO (Either Error ())
+sendFile conn transitserver appid filepath = do
+ -- establish a transit connection
+ endpoint <- establishSenderTransit conn transitserver appid
+ case endpoint of
+ Left e -> return $ Left e
+ Right ep -> do
+ -- send offer for the file
+ offerResp <- senderOfferExchange conn filepath
+ case offerResp of
+ Left s -> return (Left (NetworkError (OfferError s)))
+ Right pathToSend -> do
+ (rxAckMsg, txSha256Hash) <-
+ finally
+ (do -- send encrypted records to the peer
+ (txSha256Hash, _) <- C.runConduitRes (sendPipeline pathToSend ep)
+ -- read a record that should contain the transit Ack.
+ -- If ack is not ok or the sha256sum is incorrect, flag an error.
+ rxAckMsg <- receiveAckMessage ep
+ return (rxAckMsg, txSha256Hash))
+ (closeConnection ep)
+ case rxAckMsg of
+ Right rxSha256Hash ->
+ if txSha256Hash /= rxSha256Hash
+ then return $ Left (NetworkError (Sha256SumError "sha256 mismatch"))
+ else return (Right ())
+ Left e -> return $ Left e
+
+-- | Receive a file or directory via the established MagicWormhole connection
+receiveFile :: MagicWormhole.EncryptedConnection -> RelayEndpoint -> MagicWormhole.AppID -> TransitMsg -> IO (Either Error ())
+receiveFile conn transitserver appid transit = do
+ let abilities' = [Ability DirectTcpV1, Ability RelayV1]
+ s <- tcpListener
+ portnum <- socketPort s
+ ourHints <- buildHints portnum transitserver
+ sendTransitMsg conn abilities' (Set.toList ourHints)
+ -- now expect an offer message
+ offerMsg <- receiveWormholeMessage conn
+ case Aeson.eitherDecode (toS offerMsg) of
+ Left err -> return $ Left (NetworkError (OfferError $ "unable to decode offer msg: " <> toS err))
+ Right (MagicWormhole.File name size) -> rxFile s name size
+ Right (MagicWormhole.Directory _mode name zipSize _ _uncompressedSize) -> do
+ systemTmpDir <- getTemporaryDirectory
+ tmpDir <- createTempDirectory systemTmpDir "wormhole"
+ let zipFile = tmpDir (toS name)
+ _ <- rxFile s zipFile zipSize
+ -- TODO: check if the file system containing the current directory has
+ -- enough space, by checking the uncompressedSize and the free space.
+ _ <- unzipInto (toS name) zipFile
+ Right <$> removeFile zipFile
+ Right _ -> return $ Left (NetworkError (UnknownPeerMessage "cannot decipher the message from peer"))
+ where
+ rxFile socket name size = do
+ -- TODO: if the file already exist in the current dir, abort.
+ -- send an answer message with file_ack.
+ let ans = Answer (FileAck "ok")
+ sendWormholeMessage conn (Aeson.encode ans)
+ -- establish receive transit endpoint
+ endpoint <- establishReceiverTransit conn transitserver appid transit socket
+ case endpoint of
+ Left e -> return $ Left e
+ Right ep -> do
+ _ <- finally
+ (do
+ -- receive and decrypt records (length followed by length
+ -- sized packets). Also keep track of decrypted size in
+ -- order to know when to send the file ack at the end.
+ (rxSha256Sum, ()) <- C.runConduitRes $ receivePipeline name (fromIntegral size) ep
+ sendAckMessage ep (toS rxSha256Sum))
+ (closeConnection ep)
+ return $ Right ()
+
diff --git a/src/Transit/Internal/Messages.hs b/src/Transit/Internal/Messages.hs
new file mode 100644
--- /dev/null
+++ b/src/Transit/Internal/Messages.hs
@@ -0,0 +1,167 @@
+-- | Description: Client-to-Client messages
+-- The JSON messages are derived from these Message types.
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Transit.Internal.Messages
+ ( TransitMsg(..)
+ , Ability(..)
+ , AbilityV1(..)
+ , Hint(..)
+ , ConnectionHint(..)
+ , Ack(..)
+ , TransitAck(..)
+ ) where
+
+import Protolude
+
+import Data.Aeson
+ ( FromJSON(..)
+ , ToJSON(..)
+ , genericToJSON
+ , genericParseJSON
+ , defaultOptions
+ , fieldLabelModifier
+ , constructorTagModifier
+ , sumEncoding
+ , SumEncoding(..)
+ , camelTo2
+ )
+
+import qualified Data.Set as Set
+
+-- | Type to represent the abilities
+data AbilityV1
+ = DirectTcpV1
+ -- ^ Can send directly via TCP
+ | RelayV1
+ -- ^ Can relay via a relay server
+ deriving (Eq, Show, Generic)
+
+instance ToJSON AbilityV1 where
+ toJSON = genericToJSON
+ defaultOptions { constructorTagModifier = camelTo2 '-'}
+
+instance FromJSON AbilityV1 where
+ parseJSON = genericParseJSON
+ defaultOptions { constructorTagModifier = camelTo2 '-'}
+
+-- | Hints are messages that specify ways that the client
+-- can connect to the peer.
+data Hint = Hint { ctype :: AbilityV1
+ , priority :: Double
+ , hostname :: Text
+ , port :: Word16 }
+ deriving (Eq, Show, Generic)
+
+instance Ord Hint where
+ Hint _ p1 _ _ `compare` Hint _ p2 _ _ = Down p1 `compare` Down p2
+
+instance ToJSON Hint where
+ toJSON = genericToJSON
+ defaultOptions { fieldLabelModifier =
+ \name -> case name of
+ "ctype" -> "type"
+ _ -> name }
+
+instance FromJSON Hint where
+ parseJSON = genericParseJSON
+ defaultOptions { fieldLabelModifier =
+ \name -> case name of
+ "ctype" -> "type"
+ _ -> name }
+
+-- | Connection Hint is currently a direct hint or a relay hint
+data ConnectionHint
+ = Direct Hint
+ -- ^ Direct Hint
+ | Relay { rtype :: AbilityV1
+ , hints :: [Hint] }
+ -- ^ Relay hint
+ deriving (Eq, Show, Generic)
+
+instance Ord ConnectionHint where
+ Direct _ `compare` Direct _ = EQ
+ Direct _ `compare` Relay _ _ = LT
+ Relay _ h1 `compare` Relay _ h2 = h1 `compare` h2
+ Relay _ _ `compare` Direct _ = GT
+
+instance ToJSON ConnectionHint where
+ toJSON = genericToJSON
+ defaultOptions { sumEncoding = UntaggedValue
+ , fieldLabelModifier =
+ \name -> case name of
+ "rtype" -> "type"
+ _ -> name }
+instance FromJSON ConnectionHint where
+ parseJSON = genericParseJSON
+ defaultOptions { sumEncoding = UntaggedValue
+ , fieldLabelModifier =
+ \name -> case name of
+ "rtype" -> "type"
+ _ -> name }
+-- | Ack message type
+data Ack = FileAck Text
+ -- ^ File Ack
+ | MessageAck Text
+ -- ^ Message Ack
+ deriving (Eq, Show, Generic)
+
+instance ToJSON Ack where
+ toJSON = genericToJSON
+ defaultOptions { sumEncoding = ObjectWithSingleField
+ , constructorTagModifier = camelTo2 '_'}
+
+instance FromJSON Ack where
+ parseJSON = genericParseJSON
+ defaultOptions { sumEncoding = ObjectWithSingleField
+ , constructorTagModifier = camelTo2 '_'}
+
+-- | A newtype specifically for generating Ability JSON messages
+newtype Ability = Ability { atype :: AbilityV1 }
+ deriving (Eq, Show, Generic)
+
+instance ToJSON Ability where
+ toJSON = genericToJSON
+ defaultOptions { sumEncoding = UntaggedValue
+ , fieldLabelModifier = const "type" }
+
+instance FromJSON Ability where
+ parseJSON = genericParseJSON
+ defaultOptions { sumEncoding = UntaggedValue
+ , fieldLabelModifier = const "type" }
+
+-- | Transit, Answer and Error Message from Client to Client
+data TransitMsg = Error Text
+ | Answer Ack
+ -- ^ Answer message is sent on a successful transfer
+ | Transit { abilitiesV1 :: [Ability]
+ , hintsV1 :: Set.Set ConnectionHint }
+ -- ^ Transit message
+ deriving (Eq, Show, Generic)
+
+instance ToJSON TransitMsg where
+ toJSON = genericToJSON
+ defaultOptions { sumEncoding = ObjectWithSingleField
+ , constructorTagModifier = camelTo2 '-'
+ , fieldLabelModifier = camelTo2 '-' }
+instance FromJSON TransitMsg where
+ parseJSON = genericParseJSON
+ defaultOptions { sumEncoding = ObjectWithSingleField
+ , constructorTagModifier = camelTo2 '-'
+ , fieldLabelModifier = camelTo2 '-'}
+
+-- | Message sent by the receiver of the file to the sender
+data TransitAck
+ = TransitAck
+ { ack :: Text -- ^ "ack" is "ok" implies a successful transfer
+ , sha256 :: Text } -- ^ expected sha256 sum of the transfered file
+ deriving (Eq, Show, Generic)
+
+instance ToJSON TransitAck where
+ toJSON = genericToJSON
+ defaultOptions { sumEncoding = UntaggedValue }
+
+instance FromJSON TransitAck where
+ parseJSON = genericParseJSON
+ defaultOptions { sumEncoding = UntaggedValue }
+
diff --git a/src/Transit/Internal/Network.hs b/src/Transit/Internal/Network.hs
new file mode 100644
--- /dev/null
+++ b/src/Transit/Internal/Network.hs
@@ -0,0 +1,243 @@
+-- | Description: functions that deal with the network i/o
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Transit.Internal.Network
+ (
+ -- * build hints (direct and relay) from relay url, port number and the network interfaces.
+ buildHints
+ , buildRelayHints
+ -- * parse and build transit relay hints
+ , parseTransitRelayUri
+ , RelayEndpoint(..)
+ -- * low level bytestring buffer send/receive over a socket
+ , sendBuffer
+ , recvBuffer
+ -- * TCP Endpoint
+ , closeConnection
+ , TCPEndpoint(..)
+ , TransitEndpoint(..)
+ -- * TCP Listener that listens on a random port, Server and Client
+ , tcpListener
+ , startServer
+ , startClient
+ -- * Errors
+ , CommunicationError(..)
+ ) where
+
+import Prelude (read)
+import Protolude
+
+import Transit.Internal.Messages (ConnectionHint(..), Hint(..), AbilityV1(..))
+
+import Network.Socket
+ ( addrSocketType
+ , PortNumber
+ , addrFlags
+ , addrAddress
+ , addrProtocol
+ , addrFamily
+ , getAddrInfo
+ , SocketType ( Stream )
+ , close
+ , socket
+ , Socket(..)
+ , SockAddr
+ , connect
+ , bind
+ , listen
+ , accept
+ , defaultHints
+ , defaultPort
+ , setSocketOption
+ , SocketOption( ReuseAddr )
+ , AddrInfoFlag ( AI_NUMERICSERV )
+ , withSocketsDo
+ )
+
+import Network.Info
+ ( getNetworkInterfaces
+ , NetworkInterface(..)
+ , IPv4(..)
+ )
+
+import Network.Socket.ByteString (send, recv)
+import System.Timeout (timeout)
+import Data.Text (splitOn)
+import Data.String (String)
+import System.IO.Error (IOError)
+import qualified Crypto.Saltine.Core.SecretBox as SecretBox
+
+import qualified Data.Text.IO as TIO
+import qualified Data.Set as Set
+
+-- | Type representing the network protocol errors
+data CommunicationError
+ = ConnectionError Text
+ -- ^ We could not establish a socket connection.
+ | OfferError Text
+ -- ^ Clients could not exchange offer message.
+ | TransitError Text
+ -- ^ There was an error in transit protocol exchanges.
+ | Sha256SumError Text
+ -- ^ Sender got back a wrong sha256sum from the receiver.
+ | UnknownPeerMessage Text
+ -- ^ We could not identify the message from peer.
+ deriving (Eq, Show)
+
+-- | Listen on all the interfaces on a randomly assigned default port
+tcpListener :: IO Socket
+tcpListener = do
+ let hints' = defaultHints { addrFlags = [AI_NUMERICSERV], addrSocketType = Stream }
+ addr:_ <- getAddrInfo (Just hints') (Just "0.0.0.0") (Just (show defaultPort))
+ sock' <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+ setSocketOption sock' ReuseAddr 1
+ bind sock' (addrAddress addr)
+ listen sock' 5
+ return sock'
+
+type Hostname = Text
+
+ipv4ToHostname :: Word32 -> Hostname
+ipv4ToHostname ip =
+ let (q1, r1) = ip `divMod` 256
+ (q2, r2) = q1 `divMod` 256
+ (q3, r3) = q2 `divMod` 256
+ in
+ show r1 <> "." <> show r2 <> "." <> show r3 <> "." <> show q3
+
+buildDirectHints :: PortNumber -> IO (Set.Set ConnectionHint)
+buildDirectHints portnum = do
+ nwInterfaces <- getNetworkInterfaces
+ let nonLoopbackInterfaces =
+ filter (\nwInterface ->
+ let (IPv4 addr4) = ipv4 nwInterface
+ in
+ (ipv4ToHostname addr4 /= "0.0.0.0")
+ && (ipv4ToHostname addr4 /= "127.0.0.1"))
+ nwInterfaces
+ return $ Set.fromList $ map (\nwInterface ->
+ let (IPv4 addr4) = ipv4 nwInterface in
+ Direct Hint { hostname = ipv4ToHostname addr4
+ , port = fromIntegral portnum
+ , priority = 0
+ , ctype = DirectTcpV1 }) nonLoopbackInterfaces
+
+-- | Type representing a Relay Endpoint URL
+data RelayEndpoint
+ = RelayEndpoint
+ { relayhost :: Text
+ , relayport :: Word16
+ } deriving (Show, Eq)
+
+-- | Parse transit url of the form /tcp:hostname:port/
+parseTransitRelayUri :: String -> Maybe RelayEndpoint
+parseTransitRelayUri url =
+ let parts = splitOn ":" (toS @String @Text url)
+ (Just host') = atMay parts 1
+ (Just port') = atMay parts 2
+ in
+ if length parts == 3 && "tcp:" `isPrefixOf` url
+ then Just (RelayEndpoint { relayhost = host', relayport = read @Word16 (toS port') })
+ else Nothing
+
+-- | The client at the sending side and receiving side may be
+-- invoked with different relay hint urls. These get exchanged
+-- in the transit message. After successfully receiving the transit
+-- message, each client should combine the hints of the peer along
+-- with its relay hints to get the full set of hints.
+buildRelayHints :: RelayEndpoint -> Set.Set ConnectionHint
+buildRelayHints (RelayEndpoint host' port') =
+ Set.singleton $ Relay RelayV1 [Hint { hostname = host'
+ , port = port'
+ , priority = 0.0
+ , ctype = RelayV1 }]
+
+-- | Build a client's connection hint
+buildHints :: PortNumber -> RelayEndpoint -> IO (Set.Set ConnectionHint)
+buildHints portnum relayEndpoint = do
+ directHints <- buildDirectHints portnum
+ let relayHints = buildRelayHints relayEndpoint
+ return (directHints <> relayHints)
+
+-- | A type representing the connected TCP endpoint
+data TCPEndpoint
+ = TCPEndpoint
+ { sock :: Socket
+ , conntype :: Maybe AbilityV1
+ } deriving (Show, Eq)
+
+-- | A type representing an "authenticated" TCP endpoint
+data TransitEndpoint
+ = TransitEndpoint
+ { peerEndpoint :: TCPEndpoint
+ , senderKey :: SecretBox.Key
+ , receiverKey :: SecretBox.Key
+ } deriving (Eq)
+
+
+tryToConnect :: AbilityV1 -> Hint -> IO (Maybe TCPEndpoint)
+tryToConnect ability h@(Hint _ _ host portnum) =
+ timeout 1000000 (bracketOnError
+ (init host portnum)
+ (\(sock', _) -> close sock')
+ (\(sock', addr) -> do
+ connect sock' $ addrAddress addr
+ TIO.putStrLn "Connected"
+ return (TCPEndpoint sock' (Just ability))))
+ where
+ init host' port' = withSocketsDo $ do
+ TIO.putStrLn $ "trying to connect to " <> (show h)
+ addr <- resolve (toS host') (show port')
+ sock' <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+ return (sock', addr)
+ resolve host' port' = do
+ let hints' = defaultHints { addrSocketType = Stream }
+ addr:_ <- getAddrInfo (Just hints') (Just host') (Just port')
+ return addr
+
+-- | Low level function to send a fixed length bytestring to
+-- the peer represented by /ep/.
+sendBuffer :: TCPEndpoint -> ByteString -> IO Int
+sendBuffer ep = send (sock ep)
+
+-- | Low level function to receive a byte buffer of specified
+-- length from the peer represented by /ep/.
+recvBuffer :: TCPEndpoint -> Int -> IO ByteString
+recvBuffer ep = recv (sock ep)
+
+-- | Close the peer network connection.
+closeConnection :: TransitEndpoint -> IO ()
+closeConnection ep = close (sock (peerEndpoint ep))
+
+-- | Accept and return the TCP Endpoint representing the peer
+startServer :: Socket -> IO (Either CommunicationError TCPEndpoint)
+startServer sock' = do
+ res <- try $ accept sock' :: IO (Either IOError (Socket, SockAddr))
+ close sock'
+ return $ bimap (const (ConnectionError "accept: IO error")) (\(conn, _) -> (TCPEndpoint conn Nothing)) res
+
+-- | Try to concurrently connect to the given list of connection hints and
+-- return the first peer that succeeds.
+startClient :: [ConnectionHint] -> IO (Either CommunicationError TCPEndpoint)
+startClient hs = do
+ let sortedHs = sort hs
+ (dHs, rHs) = segregateHints sortedHs
+ TIO.putStrLn ("Direct Hints" <> (show dHs))
+ TIO.putStrLn ("Relay Hints" <> (show rHs))
+ (ep1, ep2) <- concurrently
+ (asum (map (tryToConnect DirectTcpV1) dHs))
+ (asum (map (tryToConnect RelayV1) rHs))
+ let maybeEndPoint = ep1 <|> ep2
+ case maybeEndPoint of
+ Just ep -> return (Right ep)
+ Nothing -> return (Left (ConnectionError "Peer socket is not active"))
+ where
+ -- (a -> b -> b) -> b -> [a] -> b
+ segregateHints :: [ConnectionHint] -> ([Hint], [Hint])
+ segregateHints = foldr go ([],[])
+ go :: ConnectionHint -> ([Hint], [Hint]) -> ([Hint], [Hint])
+ go hint (dhs, rhs) = case hint of
+ Direct h -> (h:dhs, rhs)
+ Relay _ hs' -> (dhs, hs' <> rhs)
+
diff --git a/src/Transit/Internal/Peer.hs b/src/Transit/Internal/Peer.hs
new file mode 100644
--- /dev/null
+++ b/src/Transit/Internal/Peer.hs
@@ -0,0 +1,401 @@
+-- | Description: Module that exchanges messages with the Peer
+{-# LANGUAGE OverloadedStrings #-}
+module Transit.Internal.Peer
+ ( makeSenderHandshake
+ , makeReceiverHandshake
+ , makeRecordKeys
+ , makeRelayHandshake
+ , senderTransitExchange
+ , senderOfferExchange
+ , sendOffer
+ , receiveOffer
+ , sendMessageAck
+ , receiveMessageAck
+ , senderHandshakeExchange
+ , receiverHandshakeExchange
+ , sendTransitMsg
+ , decodeTransitMsg
+ , makeAckMessage
+ , receiveWormholeMessage
+ , sendWormholeMessage
+ , generateTransitSide
+ , InvalidHandshake(..)
+ , sendRecord
+ , receiveRecord
+ , unzipInto
+ )
+where
+
+import Protolude hiding ((<.>))
+
+import qualified Control.Exception as E
+import qualified Crypto.Saltine.Class as Saltine
+import qualified Crypto.Saltine.Core.SecretBox as SecretBox
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Set as Set
+
+import Data.Aeson (encode, eitherDecode)
+import Data.Binary.Get (getWord32be, runGet)
+import Data.ByteString.Builder(toLazyByteString, word32BE, byteString)
+import Data.Bits (shiftL)
+import Data.Hex (hex)
+import Data.Text (toLower)
+import System.Posix.Types (FileOffset, FileMode)
+import System.PosixCompat.Files (getFileStatus, fileSize, fileMode, isDirectory)
+import System.FilePath (takeFileName, takeBaseName, dropTrailingPathSeparator, (<.>), ())
+import Crypto.Random (MonadRandom(..))
+import Data.ByteArray.Encoding (convertToBase, Base(Base16))
+import System.IO.Error (IOError)
+import System.Directory.PathWalk (pathWalk)
+import System.Directory (getTemporaryDirectory)
+import System.IO.Temp (createTempDirectory)
+import Codec.Archive.Zip ( createArchive
+ , withArchive
+ , CompressionMethod ( Deflate )
+ , mkEntrySelector
+ , unEntrySelector
+ , packDirRecur
+ , unpackInto
+ , forEntries
+ , setExternalFileAttrs)
+
+import Transit.Internal.Messages
+ ( TransitMsg(..)
+ , TransitAck(..)
+ , Ack( FileAck, MessageAck )
+ , Ability(..)
+ , AbilityV1(..)
+ , ConnectionHint)
+import Transit.Internal.Network
+ ( TCPEndpoint(..)
+ , sendBuffer
+ , recvBuffer
+ , CommunicationError(..))
+import Transit.Internal.Crypto
+ ( encrypt
+ , decrypt
+ , deriveKeyFromPurpose
+ , Purpose(..)
+ , PlainText(..)
+ , CipherText(..)
+ , CryptoError(..))
+
+import qualified MagicWormhole
+
+-- | Make a bytestring for the handshake message sent by the
+-- sender which is of the form "transit sender XXXXXXX..XX ready\n\n"
+-- where /XXXXXX..XX/ is the hex ascii representation of the sender
+-- handshake key.
+makeSenderHandshake :: SecretBox.Key -> ByteString
+makeSenderHandshake key =
+ (toS @Text @ByteString "transit sender ") <> hexid <> (toS @Text @ByteString " ready\n\n")
+ where
+ subkey = deriveKeyFromPurpose SenderHandshake key
+ hexid = toS (toLower (toS @ByteString @Text (hex subkey)))
+
+-- | Make a bytestring for the handshake message sent by the receiver
+-- which is of the form "transit receiver XXXX...XX ready\n\n" where
+-- /XXXX...XX/ is the receiver handshake key.
+makeReceiverHandshake :: SecretBox.Key -> ByteString
+makeReceiverHandshake key =
+ (toS @Text @ByteString "transit receiver ") <> hexid <> (toS @Text @ByteString " ready\n\n")
+ where
+ subkey = deriveKeyFromPurpose ReceiverHandshake key
+ hexid = toS (toLower (toS @ByteString @Text (hex subkey)))
+
+-- | create relay handshake bytestring
+-- "please relay HEXHEX for side XXXXX\n"
+makeRelayHandshake :: SecretBox.Key -> MagicWormhole.Side -> ByteString
+makeRelayHandshake key (MagicWormhole.Side side) =
+ (toS @Text @ByteString "please relay ") <> token <> (toS @Text @ByteString " for side ") <> sideBytes <> "\n"
+ where
+ subkey = deriveKeyFromPurpose RelayHandshake key
+ token = toS (toLower (toS @ByteString @Text (hex subkey)))
+ sideBytes = toS @Text @ByteString side
+
+-- | Make sender and receiver symmetric keys for the records transmission.
+-- Records are chunks of data corresponding to the blocks of the file.
+-- Sender record key is used for decrypting incoming records and receiver
+-- record key is for sending file_ack back to the sender.
+makeRecordKeys :: SecretBox.Key -> Either CryptoError (SecretBox.Key, SecretBox.Key)
+makeRecordKeys key =
+ maybe (Left (KeyGenError "Could not generate record keys")) Right keyPair
+ where
+ keyPair = (,) <$> makeSenderRecordKey key
+ <*> makeReceiverRecordKey key
+ makeSenderRecordKey :: SecretBox.Key -> Maybe SecretBox.Key
+ makeSenderRecordKey = Saltine.decode . (deriveKeyFromPurpose SenderRecord)
+ makeReceiverRecordKey :: SecretBox.Key -> Maybe SecretBox.Key
+ makeReceiverRecordKey = Saltine.decode . (deriveKeyFromPurpose ReceiverRecord)
+
+-- |'senderTransitExchange' exchanges transit message with the peer.
+-- Sender sends a transit message with its abilities and hints.
+-- Receiver sends either another Transit message or an Error message.
+senderTransitExchange :: MagicWormhole.EncryptedConnection -> [ConnectionHint] -> IO (Either CommunicationError TransitMsg)
+senderTransitExchange conn hs = do
+ let abilities' = [Ability DirectTcpV1, Ability RelayV1]
+ (_, rxMsg) <- concurrently (sendTransitMsg conn abilities' hs) receiveTransitMsg
+ case eitherDecode (toS rxMsg) of
+ Right t@(Transit _ _) -> return (Right t)
+ Left s -> return (Left (TransitError (toS s)))
+ Right (Error errstr) -> return (Left (TransitError errstr))
+ Right (Answer _) -> return (Left (TransitError "Answer message from the peer is unexpected"))
+ where
+ receiveTransitMsg = do
+ -- receive the transit from the receiving side
+ responseMsg <- receiveWormholeMessage conn
+ return responseMsg
+
+-- | create and send a Transit message to the peer.
+sendTransitMsg :: MagicWormhole.EncryptedConnection -> [Ability] -> [ConnectionHint] -> IO ()
+sendTransitMsg conn abilities' hints' = do
+ -- create transit message
+ let txTransitMsg = Transit abilities' (Set.fromList hints')
+ let encodedTransitMsg = toS (encode txTransitMsg)
+ -- send the transit message (dictionary with key as "transit" and value as abilities)
+ MagicWormhole.sendMessage conn (MagicWormhole.PlainText encodedTransitMsg)
+
+-- | Parse the given bytestring into a Transit Message
+decodeTransitMsg :: ByteString -> Either CommunicationError TransitMsg
+decodeTransitMsg received =
+ case eitherDecode (toS received) of
+ Right transitMsg -> Right transitMsg
+ Left err -> Left $ TransitError (toS err)
+
+-- | Send an offer message to the connected peer over the wormhole
+sendOffer :: MagicWormhole.EncryptedConnection -> MagicWormhole.Offer -> IO ()
+sendOffer conn offer =
+ MagicWormhole.sendMessage conn (MagicWormhole.PlainText (toS (encode offer)))
+
+-- | receive a message over wormhole and try to decode it as an offer message.
+-- If it is not an offer message, pass the raw bytestring as a Left value.
+receiveOffer :: MagicWormhole.EncryptedConnection -> IO (Either ByteString MagicWormhole.Offer)
+receiveOffer conn = do
+ received <- receiveWormholeMessage conn
+ case eitherDecode (toS received) of
+ Right msg@(MagicWormhole.Message _) -> return $ Right msg
+ Right file@(MagicWormhole.File _ _) -> return $ Right file
+ Right dir@(MagicWormhole.Directory _ _ _ _ _) -> return $ Right dir
+ Left _ -> return $ Left received
+
+-- | Receive an Ack message over the wormhole connection
+receiveMessageAck :: MagicWormhole.EncryptedConnection -> IO (Either CommunicationError ())
+receiveMessageAck conn = do
+ rxTransitMsg <- receiveWormholeMessage conn
+ case eitherDecode (toS rxTransitMsg) of
+ Left s -> return $ Left (TransitError (show s))
+ Right (Answer (MessageAck msg')) | msg' == "ok" -> return $ Right ()
+ | otherwise -> return $ Left (TransitError "Message ack failed")
+ Right s -> return $ Left (TransitError (show s))
+
+-- | Send an Ack message as a regular text message encapsulated in
+-- an 'Answer' message over the wormhole connection
+sendMessageAck :: MagicWormhole.EncryptedConnection -> Text -> IO ()
+sendMessageAck conn msg = do
+ let ackMessage = Answer (MessageAck msg)
+ MagicWormhole.sendMessage conn (MagicWormhole.PlainText (toS (encode ackMessage)))
+
+-- | Exchange offer message with the peer over the wormhole connection
+senderOfferExchange :: MagicWormhole.EncryptedConnection -> FilePath -> IO (Either Text FilePath)
+senderOfferExchange conn path = do
+ (filePath, rx) <- concurrently sendFileOrDirOffer receiveResponse
+ -- receive file ack message {"answer": {"file_ack": "ok"}}
+ case eitherDecode (toS rx) of
+ Left s -> return $ Left (toS s)
+ Right (Error errstr) -> return $ Left (toS errstr)
+ Right (Answer (FileAck msg)) | msg == "ok" -> return (Right filePath)
+ | otherwise -> return $ Left "Did not get file ack. Exiting"
+ Right (Answer (MessageAck _)) -> return $ Left "expected file ack, got message ack instead"
+ Right (Transit _ _) -> return $ Left "unexpected transit message"
+ where
+ sendFileOrDirOffer :: IO FilePath
+ sendFileOrDirOffer = do
+ isDir <- isDirectory <$> getFileStatus path
+ if isDir
+ then sendDirOffer
+ else sendFileOffer
+ receiveResponse :: IO ByteString
+ receiveResponse = do
+ rxFileOffer <- receiveWormholeMessage conn
+ return rxFileOffer
+ getFileSize :: FilePath -> IO FileOffset
+ getFileSize file = fileSize <$> getFileStatus file
+ sendFileOffer = do
+ size <- getFileSize path
+ let fileOffer = MagicWormhole.File (toS (takeFileName path)) size
+ sendOffer conn fileOffer
+ return path
+ sendDirOffer = do
+ (zipFilePath, (totalFiles, totalSize)) <- zipDir path
+ size <- getFileSize zipFilePath
+ let dirOffer = MagicWormhole.Directory MagicWormhole.ZipFileDeflated (toS (takeBaseName (dropTrailingPathSeparator path))) (fromIntegral size) (fromIntegral totalSize) (fromIntegral totalFiles)
+ sendOffer conn dirOffer
+ return zipFilePath
+
+-- | Receive a bytestring via the established wormhole connection
+receiveWormholeMessage :: MagicWormhole.EncryptedConnection -> IO ByteString
+receiveWormholeMessage conn = do
+ MagicWormhole.PlainText msg <- atomically $ MagicWormhole.receiveMessage conn
+ return msg
+
+-- | Send a bytestring over the established wormhole connection
+sendWormholeMessage :: MagicWormhole.EncryptedConnection -> BL.ByteString -> IO ()
+sendWormholeMessage conn msg =
+ MagicWormhole.sendMessage conn (MagicWormhole.PlainText (toS msg))
+
+-- | Error type for the Peer module
+data InvalidHandshake = InvalidHandshake
+ -- ^ Handshake with the peer didn't succeed
+ | InvalidRelayHandshake
+ -- ^ Handshake with the relay server didn't succeed
+ deriving (Show, Eq)
+
+instance E.Exception InvalidHandshake where
+
+-- | Exchange handshake message with the Relay server.
+relayHandshakeExchange :: TCPEndpoint -> SecretBox.Key -> MagicWormhole.Side -> IO ()
+relayHandshakeExchange ep key side = do
+ r <- sendRelayHandshake >> receiveAck
+ if r == "ok\n"
+ then return ()
+ else throwIO InvalidRelayHandshake
+ where
+ sendRelayHandshake = sendBuffer ep sHandshakeMsg
+ sHandshakeMsg = makeRelayHandshake key side
+ receiveAck = recvByteString (BS.length rHandshakeMsg)
+ rHandshakeMsg = "ok\n"
+ recvByteString n = recvBuffer ep n
+
+-- | Sender side exchange of the handshake messages. Sender sends send-side handshake
+-- message created by 'makeSenderHandshake' and concurrently receives the handshake
+-- message from the receive side and compares it with the bytestring created by
+-- 'makeReceiverHandshake'. If it matches, then it sends "go\n" to the receiver, else
+-- it sends "nevermind\n" to the receiver and returns an 'InvalidHandshake'.
+senderHandshakeExchange :: TCPEndpoint -> SecretBox.Key -> MagicWormhole.Side -> IO (Either InvalidHandshake ())
+senderHandshakeExchange ep key side = do
+ when (conntype ep == Just RelayV1) $ do
+ relayHandshakeExchange ep key side
+ (_, r) <- concurrently sendHandshake rxHandshake
+ if r == rHandshakeMsg
+ then do
+ _ <- sendGo
+ return $ Right ()
+ else do
+ _ <- sendNeverMind
+ return $ Left InvalidHandshake
+ where
+ sendHandshake = sendBuffer ep sHandshakeMsg
+ rxHandshake = recvByteString (BS.length rHandshakeMsg)
+ sendGo = sendBuffer ep (toS @Text @ByteString "go\n")
+ sendNeverMind = sendBuffer ep (toS @Text @ByteString "nevermind\n")
+ sHandshakeMsg = makeSenderHandshake key
+ rHandshakeMsg = makeReceiverHandshake key
+ recvByteString n = recvBuffer ep n
+
+-- | Receiver side exchange of handshake messages. Receiver sends the receive-side
+-- handshake message appended with "go\n" and receives the handshake message from
+-- the sender. It then compares the message received from the sender with the locally
+-- computed sender handshake bytestring appended with "go\n". If they don't match, it
+-- returns an 'InvalidHandshake'.
+receiverHandshakeExchange :: TCPEndpoint -> SecretBox.Key -> MagicWormhole.Side -> IO (Either InvalidHandshake ())
+receiverHandshakeExchange ep key side = do
+ when (conntype ep == Just RelayV1) $ do
+ relayHandshakeExchange ep key side
+ (_, r') <- concurrently sendHandshake rxHandshake
+ r'' <- recvByteString (BS.length "go\n")
+ if (r' <> r'') == sHandshakeMsg <> "go\n"
+ then return $ Right ()
+ else return $ Left InvalidHandshake
+ where
+ sendHandshake = sendBuffer ep rHandshakeMsg
+ rxHandshake = recvByteString (BS.length sHandshakeMsg)
+ sHandshakeMsg = makeSenderHandshake key
+ rHandshakeMsg = makeReceiverHandshake key
+ recvByteString n = recvBuffer ep n
+
+-- | Create an encrypted Transit Ack message
+makeAckMessage :: SecretBox.Key -> ByteString -> Either CryptoError CipherText
+makeAckMessage key sha256Sum =
+ let transitAckMsg = TransitAck "ok" (toS @ByteString @Text sha256Sum)
+ in
+ encrypt key Saltine.zero (PlainText (BL.toStrict (encode transitAckMsg)))
+
+-- | A Record is an encrypted chunk of byte string. On the wire, a header of
+-- 4 bytes which denotes the length of the payload is sent before sending the
+-- actual payload.
+sendRecord :: TCPEndpoint -> ByteString -> IO (Either CommunicationError Int)
+sendRecord ep record = do
+ -- send size of the encrypted payload as 4 bytes, then send record
+ -- format sz as a fixed 4 byte bytestring
+ let payloadSize = word32BE (fromIntegral (BS.length record))
+ payload = byteString record
+ packet = payloadSize <> payload
+ res <- try $ sendBuffer ep (BL.toStrict (toLazyByteString packet)) :: IO (Either IOError Int)
+ case res of
+ Left e -> return $ Left (ConnectionError (show e))
+ Right x -> return $ Right x
+
+-- | Receive a packet corresponding to a record (4-byte header representing the
+-- length /n/, of the record, followed by /n/ bytes of encrypted payload) and then
+-- decrypts and returns the payload.
+receiveRecord :: TCPEndpoint -> SecretBox.Key -> IO (Either CryptoError ByteString)
+receiveRecord ep key = do
+ -- read 4 bytes that consists of length
+ -- read as much bytes specified by the length. That would be encrypted record
+ -- decrypt the record
+ lenBytes <- recvBuffer ep 4
+ let len = runGet getWord32be (BL.fromStrict lenBytes)
+ encRecord <- recvBuffer ep (fromIntegral len)
+ case decrypt key (CipherText encRecord) of
+ Left e -> return $ Left e
+ Right (PlainText plaintext, _) -> return $ Right plaintext
+
+-- | There is a separate 8-bytes of random 'side' for Transit protocol, which
+-- is different from the 'side' used in the wormhole encrypted channel establishment
+generateTransitSide :: MonadRandom m => m MagicWormhole.Side
+generateTransitSide = do
+ randomBytes <- getRandomBytes 8
+ pure . MagicWormhole.Side . toS @ByteString . convertToBase Base16 $ (randomBytes :: ByteString)
+
+type DirState = (Int, FileOffset)
+
+-- | Given an input FilePath representing a directory, zip
+-- the entire directory contents and return the path to the
+-- zip file and a state (number of files and total size of all
+-- the files).
+zipDir :: FilePath -> IO (FilePath, DirState)
+zipDir filePath = do
+ systemTmpDir <- getTemporaryDirectory
+ tmpDir <- createTempDirectory systemTmpDir "wormhole"
+ let dirName = takeBaseName (dropTrailingPathSeparator filePath)
+ let zipFileName = tmpDir dirName <.> "zip"
+ ((_, stats), _) <- concurrently
+ (runStateT (dirStats filePath) (0,0))
+ (do
+ createArchive zipFileName $
+ packDirRecur Deflate mkEntrySelector filePath
+ withArchive zipFileName $ do
+ forEntries $ \selector -> do
+ mode <- liftIO $ getFileMode (dirName unEntrySelector selector)
+ setExternalFileAttrs (fromIntegral (mode `shiftL` 16)) selector)
+ return (zipFileName, stats)
+ where
+ getFileMode :: FilePath -> IO FileMode
+ getFileMode file = fileMode <$> getFileStatus file
+
+dirStats :: FilePath -> StateT DirState IO ()
+dirStats filePath = do
+ pathWalk filePath $ \root _dirs files -> do
+ forM_ files $ \file -> do
+ size <- liftIO (getFileSize (root file))
+ (numFiles, totalSize) <- get
+ put (numFiles + 1, totalSize + size)
+ where
+ getFileSize :: FilePath -> IO FileOffset
+ getFileSize file = fileSize <$> getFileStatus file
+
+-- | unzip the given zip file into the especified directory
+-- under current working directory
+unzipInto :: FilePath -> FilePath -> IO ()
+unzipInto dirname zipFilePath = withArchive zipFilePath (unpackInto dirname)
diff --git a/src/Transit/Internal/Pipeline.hs b/src/Transit/Internal/Pipeline.hs
new file mode 100644
--- /dev/null
+++ b/src/Transit/Internal/Pipeline.hs
@@ -0,0 +1,139 @@
+-- | Description: Conduit pipelines for sending and receiving files and directories
+module Transit.Internal.Pipeline
+ ( sendPipeline
+ , receivePipeline
+ -- * for tests
+ , assembleRecordC
+ , decryptC
+ , encryptC
+ )
+where
+
+import Protolude
+
+import Crypto.Hash (SHA256(..))
+import Data.Conduit ((.|))
+import Data.ByteString.Builder(toLazyByteString, word32BE)
+import Data.Binary.Get (getWord32be, runGet)
+
+import qualified Crypto.Hash as Hash
+import qualified Conduit as C
+import qualified Data.Conduit.Network as CN
+import qualified Data.Conduit.Binary as CB
+import qualified Data.Binary.Builder as BB
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BL
+import qualified Crypto.Saltine.Core.SecretBox as SecretBox
+import qualified Crypto.Saltine.Class as Saltine
+
+import Transit.Internal.Network (TCPEndpoint(..), TransitEndpoint(..))
+import Transit.Internal.Crypto (encrypt, decrypt, PlainText(..), CipherText(..), CryptoError(..))
+
+-- | Given the peer network socket and the file path to be sent, this Conduit
+-- pipeline reads the file, encrypts and send it over the network. A sha256
+-- sum is calculated on the input before encryption to compare with the
+-- receiver's decrypted copy.
+sendPipeline :: C.MonadResource m =>
+ FilePath
+ -> TransitEndpoint
+ -> C.ConduitM a c m (Text, ())
+sendPipeline fp (TransitEndpoint (TCPEndpoint s _) key _) =
+ C.sourceFile fp .| sha256PassThroughC `C.fuseBoth` (encryptC key .| CN.sinkSocket s)
+
+-- | Receive the encrypted bytestream from a network socket, decrypt it and
+-- write it into a file, also calculating the sha256 sum of the decrypted
+-- output along the way.
+receivePipeline :: C.MonadResource m =>
+ FilePath
+ -> Int
+ -> TransitEndpoint
+ -> C.ConduitM a c m (Text, ())
+receivePipeline fp len (TransitEndpoint (TCPEndpoint s _) key _) =
+ CN.sourceSocket s
+ .| assembleRecordC
+ .| decryptC key
+ .| CB.isolate len
+ .| sha256PassThroughC `C.fuseBoth` C.sinkFileCautious fp
+
+-- | A conduit function to encrypt the incoming byte stream with the given key
+encryptC :: MonadIO m => SecretBox.Key -> C.ConduitT ByteString ByteString m ()
+encryptC key = loop Saltine.zero
+ where
+ loop nonce = do
+ b <- C.await
+ case b of
+ Nothing -> return ()
+ Just chunk -> do
+ let cipherText = encrypt key nonce (PlainText chunk)
+ case cipherText of
+ Right (CipherText cipherText') -> do
+ let cipherTextSize = toLazyByteString (word32BE (fromIntegral (BS.length cipherText')))
+ C.yield (toS cipherTextSize)
+ C.yield cipherText'
+ loop (Saltine.nudge nonce)
+ Left e -> throwIO e
+
+-- | A conduit function to decrypt the incoming byte stream with the given key
+decryptC :: MonadIO m => SecretBox.Key -> C.ConduitT ByteString ByteString m ()
+decryptC key = loop Saltine.zero
+ where
+ loop :: MonadIO m => SecretBox.Nonce -> C.ConduitT ByteString ByteString m ()
+ loop seqNum = do
+ b <- C.await
+ case b of
+ Nothing -> return ()
+ Just bs ->
+ case decrypt key (CipherText bs) of
+ Right (PlainText plainText, nonce) -> do
+ let seqNumLE = BS.reverse $ toS $ Saltine.encode seqNum
+ seqNum' = Saltine.decode (toS seqNumLE)
+ if Just nonce /= seqNum'
+ then throwIO (BadNonce "nonce decoding failed or packets received out of order.")
+ else do
+ C.yield plainText
+ loop (Saltine.nudge seqNum)
+ Left e -> throwIO e
+
+sha256PassThroughC :: (Monad m) => C.ConduitT ByteString ByteString m Text
+sha256PassThroughC = loop $! Hash.hashInitWith SHA256
+ where
+ loop :: (Monad m) => Hash.Context SHA256 -> C.ConduitT ByteString ByteString m Text
+ loop ctx = do
+ b <- C.await
+ case b of
+ Nothing -> return $! show (Hash.hashFinalize ctx)
+ Just bs -> do
+ C.yield bs
+ loop $! Hash.hashUpdate ctx bs
+
+-- | The decryption conduit computation would succeed only if a complete
+-- bytestream that represents an encrypted block of data is given to it.
+-- However, the upstream elements may chunk the data for which one may not
+-- have control of. The encrypted packet on the wire has a 4-byte length
+-- header, so we could first read it and assemble a complete encrypted
+-- block into downstream.
+assembleRecordC :: Monad m => C.ConduitT ByteString ByteString m ()
+assembleRecordC = do
+ hdr <- getChunk 4
+ let len = runGet getWord32be (BL.fromStrict hdr)
+ packet <- getChunk (fromIntegral len)
+ C.yield packet
+ assembleRecordC
+ where
+ getChunk :: Monad m => Int -> C.ConduitT ByteString ByteString m ByteString
+ getChunk size = go size BB.empty
+ go :: Monad m => Int -> BB.Builder -> C.ConduitT ByteString ByteString m ByteString
+ go size res = do
+ let residue = BL.toStrict . BB.toLazyByteString $ res
+ b <- C.await
+ case b of
+ Nothing -> return residue
+ Just bs | size < BS.length bs -> do
+ let (f, l) = BS.splitAt size bs
+ C.leftover l
+ return $ residue <> f
+ | size == BS.length bs -> return (residue <> bs)
+ | otherwise -> do
+ let want = size - BS.length bs
+ go want $ BB.fromByteString (residue <> bs)
+
diff --git a/tests/CryptoTests.hs b/tests/CryptoTests.hs
new file mode 100644
--- /dev/null
+++ b/tests/CryptoTests.hs
@@ -0,0 +1,36 @@
+-- | Crypto module tests
+module CryptoTests
+ ( cryptoRoundTripTests
+ ) where
+
+import Protolude
+
+import Hedgehog (forAll, property, (===), failure, Property, Group(..), checkSequential)
+
+import qualified Transit.Internal.Crypto as C
+import qualified Crypto.Saltine.Class as Saltine
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+
+import qualified Generator
+
+prop_roundTrip :: Property
+prop_roundTrip = property $ do
+ purpose <- forAll Generator.purposeGen
+ secret <- forAll $ Gen.bytes (Range.singleton 32)
+ nonceBytes <- forAll Generator.nonceBytesGen
+ let nonce = fromMaybe (panic "cannot decode nonce") $ Saltine.decode nonceBytes
+ let secret' = fromMaybe (panic "cannot decode secret") $ Saltine.decode secret
+ let key = C.deriveKeyFromPurpose purpose secret'
+ let key' = fromMaybe (panic "cannot decode key") $ Saltine.decode key
+ plaintext <- forAll $ Gen.bytes (Range.linear 1 256)
+ let result = C.encrypt key' nonce (C.PlainText plaintext) >>= C.decrypt key'
+ case result of
+ Right (pt, _) -> pt === C.PlainText plaintext
+ Left _ -> failure
+
+cryptoRoundTripTests :: IO Bool
+cryptoRoundTripTests =
+ checkSequential $ Group "Crypto"
+ [ ("encrypt decrypt roundtrip", prop_roundTrip)
+ ]
diff --git a/tests/Generator.hs b/tests/Generator.hs
new file mode 100644
--- /dev/null
+++ b/tests/Generator.hs
@@ -0,0 +1,84 @@
+-- | Hedgehog generators for the messages
+module Generator
+ ( abilityGen
+ , abilityV1Gen
+ , hintGen
+ , connectionHintGen
+ , ackGen
+ , transitMsgGen
+ , transitAckGen
+ , nonceBytesGen
+ , purposeGen
+ )
+where
+
+import Protolude
+
+import Hedgehog (MonadGen(..))
+import qualified Crypto.Saltine.Class as Saltine
+import qualified Crypto.Saltine.Core.SecretBox as SecretBox
+import Crypto.Saltine.Internal.ByteSizes (boxNonce)
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+
+import Transit.Internal.Messages
+ ( Ability(..)
+ , AbilityV1(..)
+ , Hint(..)
+ , ConnectionHint(..)
+ , Ack(..)
+ , TransitMsg(..)
+ , TransitAck(..)
+ )
+import qualified Transit.Internal.Crypto as C
+
+abilityGen :: MonadGen m => m Ability
+abilityGen = Ability <$> abilityV1Gen
+
+abilityV1Gen :: MonadGen m => m AbilityV1
+abilityV1Gen = Gen.choice
+ [ pure DirectTcpV1
+ , pure RelayV1
+ ]
+
+hintGen :: MonadGen m => m Hint
+hintGen = Hint <$> abilityV1Gen
+ <*> Gen.double (Range.linearFrac 0.0 5.0)
+ <*> Gen.text (Range.linear 0 100) Gen.unicode
+ <*> Gen.word16 (Range.linear 0 maxBound)
+
+connectionHintGen :: MonadGen m => m ConnectionHint
+connectionHintGen = Gen.choice
+ [ Direct <$> hintGen
+ , Relay <$> abilityV1Gen <*> Gen.list (Range.linear 0 10) hintGen
+ ]
+
+ackGen :: MonadGen m => m Ack
+ackGen = Gen.choice
+ [ FileAck <$> Gen.text (Range.linear 0 100) Gen.ascii
+ , MessageAck <$> Gen.text (Range.linear 0 100) Gen.ascii
+ ]
+
+transitMsgGen :: MonadGen m => m TransitMsg
+transitMsgGen = Gen.choice
+ [ Error <$> Gen.text (Range.linear 0 100) Gen.unicode
+ , Answer <$> ackGen
+ , Transit
+ <$> Gen.list (Range.linear 0 5) abilityGen
+ <*> Gen.set (Range.linear 0 5) connectionHintGen
+ ]
+
+transitAckGen :: MonadGen m => m TransitAck
+transitAckGen = TransitAck
+ <$> Gen.text (Range.linear 0 5) Gen.unicode
+ <*> Gen.text (Range.singleton 64) Gen.hexit
+
+nonceBytesGen :: MonadGen m => m ByteString
+nonceBytesGen = Gen.bytes (Range.singleton boxNonce)
+
+purposeGen :: MonadGen m => m C.Purpose
+purposeGen = Gen.choice [ pure C.SenderHandshake
+ , pure C.ReceiverHandshake
+ , pure C.SenderRecord
+ , pure C.ReceiverRecord
+ , pure C.RelayHandshake ]
diff --git a/tests/Main.hs b/tests/Main.hs
new file mode 100644
--- /dev/null
+++ b/tests/Main.hs
@@ -0,0 +1,17 @@
+module Main (main) where
+
+import Protolude
+
+import qualified ProtocolTests
+import qualified MessagesTests
+import qualified PipelineTests
+import qualified CryptoTests
+
+main :: IO ()
+main = do
+ ProtocolTests.tests
+ MessagesTests.tests
+ PipelineTests.tests
+ MessagesTests.messagesRoundTripTests >>
+ CryptoTests.cryptoRoundTripTests >>
+ return ()
diff --git a/tests/MessagesTests.hs b/tests/MessagesTests.hs
new file mode 100644
--- /dev/null
+++ b/tests/MessagesTests.hs
@@ -0,0 +1,173 @@
+{-# LANGUAGE OverloadedStrings #-}
+module MessagesTests
+ ( tests
+ , messagesRoundTripTests
+ )
+where
+
+import Protolude
+
+import qualified Data.Set as Set
+
+import Transit.Internal.Messages
+
+import Test.Hspec
+import Data.Aeson
+ ( encode
+ , decode
+ , eitherDecode
+ )
+import Hedgehog (forAll, property, Property, Group(..), checkSequential, tripping)
+import qualified Generator
+
+tests :: IO ()
+tests = hspec $ do
+ describe "Ability tests" $ do
+ it "encode Ability" $ do
+ encode DirectTcpV1 `shouldBe` "\"direct-tcp-v1\""
+ encode RelayV1 `shouldBe` "\"relay-v1\""
+ it "decode Ability" $ do
+ let s1 = "\"direct-tcp-v1\"" :: Text
+ decode (toS s1) `shouldBe` Just DirectTcpV1
+ let s2 = "\"relay-v1\"" :: Text
+ decode (toS s2) `shouldBe` Just RelayV1
+ describe "Hint tests" $ do
+ it "encode Hint" $ do
+ let h1 = Hint { ctype = DirectTcpV1
+ , priority = 0.5
+ , hostname = "foo.bar.baz"
+ , port = 1234 }
+ encode h1 `shouldBe` "{\"hostname\":\"foo.bar.baz\",\"priority\":0.5,\"type\":\"direct-tcp-v1\",\"port\":1234}"
+ it "decode Hint" $ do
+ let h1 = "{\"hostname\":\"foo.bar.baz\",\"priority\":0.5,\"type\":\"direct-tcp-v1\",\"port\":1234}" :: Text
+ decode (toS h1) `shouldBe` Just Hint { ctype = DirectTcpV1
+ , priority = 0.5
+ , hostname = "foo.bar.baz"
+ , port = 1234 }
+ describe "ConnectionHint tests" $ do
+ it "encode Direct ConnectionHint" $ do
+ let h1 = Hint { ctype = DirectTcpV1
+ , priority = 0.5
+ , hostname = "foo.bar.baz"
+ , port = 1234 }
+ ch1 = Direct h1
+ encode ch1 `shouldBe` "{\"hostname\":\"foo.bar.baz\",\"priority\":0.5,\"type\":\"direct-tcp-v1\",\"port\":1234}"
+ it "encode Relay ConnectionHint" $ do
+ let h1 = Hint { ctype = DirectTcpV1
+ , priority = 0.5
+ , hostname = "foo.bar.baz"
+ , port = 1234 }
+ ch1 = Relay { rtype = RelayV1
+ , hints = [h1] }
+ encode ch1 `shouldBe` "{\"hints\":[{\"hostname\":\"foo.bar.baz\",\"priority\":0.5,\"type\":\"direct-tcp-v1\",\"port\":1234}],\"type\":\"relay-v1\"}"
+ it "decode Direct ConnectionHint" $ do
+ let h1text = "{\"hostname\":\"foo.bar.baz\",\"priority\":0.5,\"type\":\"direct-tcp-v1\",\"port\":1234}" :: Text
+ decode (toS h1text) `shouldBe` Just (Direct Hint { ctype = DirectTcpV1
+ , priority = 0.5
+ , hostname = "foo.bar.baz"
+ , port = 1234 })
+ it "decode Relay ConnectionHint" $ do
+ let h1text = "{\"type\": \"relay-v1\", \"hints\": [{\"hostname\":\"foo.bar.baz\",\"priority\":0.5,\"type\":\"direct-tcp-v1\",\"port\":1234}]}" :: Text
+ h1 = Hint { ctype = DirectTcpV1
+ , priority = 0.5
+ , hostname = "foo.bar.baz"
+ , port = 1234 }
+ decode (toS h1text) `shouldBe` Just Relay { rtype = RelayV1
+ , hints = [h1] }
+
+ it "encode and decode Transit type" $ do
+ let t1 = Transit { abilitiesV1 = [Ability DirectTcpV1, Ability RelayV1]
+ , hintsV1 = Set.fromList [ch1, ch2] }
+ h1 = Hint { ctype = DirectTcpV1
+ , priority = 0.5
+ , hostname = "foo.bar.baz"
+ , port = 1234 }
+ ch1 = Direct h1
+ h2 = Hint { ctype = DirectTcpV1
+ , priority = 0.5
+ , hostname = "foo.bar.baz"
+ , port = 1234 }
+ ch2 = Relay { rtype = RelayV1
+ , hints = [h2] }
+ h3 = Hint { ctype = DirectTcpV1
+ , priority = 0.0
+ , hostname = "192.168.1.106"
+ , port = 36097 }
+ ch3 = Direct h3
+ h4 = Hint { ctype = DirectTcpV1
+ , priority = 0.0
+ , hostname = "transit.magic-wormhole.io"
+ , port = 4001 }
+ ch4 = Relay { rtype = RelayV1
+ , hints = [h4] }
+ t2 = Transit { abilitiesV1 = [Ability DirectTcpV1, Ability RelayV1]
+ , hintsV1 = Set.fromList [ch3 ,ch4] }
+ t1text = "{\"transit\":{\"hints-v1\":[{\"hostname\":\"foo.bar.baz\",\"priority\":0.5,\"type\":\"direct-tcp-v1\",\"port\":1234},{\"hints\":[{\"hostname\":\"foo.bar.baz\",\"priority\":0.5,\"type\":\"direct-tcp-v1\",\"port\":1234}],\"type\":\"relay-v1\"}],\"abilities-v1\":[{\"type\":\"direct-tcp-v1\"},{\"type\":\"relay-v1\"}]}}" :: Text
+ t2text = "{\"transit\": {\"abilities-v1\": [{\"type\": \"direct-tcp-v1\"}, {\"type\": \"relay-v1\"}], \"hints-v1\": [{\"priority\": 0.0, \"hostname\": \"192.168.1.106\", \"type\": \"direct-tcp-v1\", \"port\": 36097}, {\"type\": \"relay-v1\", \"hints\": [{\"priority\": 0.0, \"hostname\": \"transit.magic-wormhole.io\", \"type\": \"direct-tcp-v1\", \"port\": 4001}]}]}}" :: ByteString
+ encode t1 `shouldBe` toS t1text
+ decode (encode t1) `shouldBe` Just t1
+ decode (toS t2text) `shouldBe` Just t2
+
+ describe "Ack message tests" $ do
+ it "encode and decode FileAck responses" $ do
+ let f1 = FileAck "ok"
+ encode f1 `shouldBe` "{\"file_ack\":\"ok\"}"
+ decode (encode f1) `shouldBe` Just f1
+
+ describe "Response message tests" $ do
+ it "encode and decode Error response" $ do
+ let r1 = Error "transfer rejected"
+ encode r1 `shouldBe` "{\"error\":\"transfer rejected\"}"
+ decode (encode r1) `shouldBe` Just r1
+ it "encode and decode answer response" $ do
+ let a1 = Answer (FileAck "ok")
+ encode a1 `shouldBe` "{\"answer\":{\"file_ack\":\"ok\"}}"
+ decode (encode a1) `shouldBe` Just a1
+
+ describe "Transit Ack tests" $ do
+ it "encode and decode Transit Ack from receiver to sender" $ do
+ let a1 = TransitAck "ok" "e4f1684a5375ebf7f1dcde02a66026f937a8c6195adf31813ef21b3ccadfb11f"
+ encode a1 `shouldBe` "{\"ack\":\"ok\",\"sha256\":\"e4f1684a5375ebf7f1dcde02a66026f937a8c6195adf31813ef21b3ccadfb11f\"}"
+ decode (encode a1) `shouldBe` Just a1
+
+prop_abilityTrip :: Property
+prop_abilityTrip = property $ do
+ x <- forAll Generator.abilityGen
+ tripping x encode eitherDecode
+
+prop_hintTrip :: Property
+prop_hintTrip = property $ do
+ x <- forAll Generator.hintGen
+ tripping x encode eitherDecode
+
+prop_connectionHintTrip :: Property
+prop_connectionHintTrip = property $ do
+ x <- forAll Generator.connectionHintGen
+ tripping x encode eitherDecode
+
+prop_ackTrip :: Property
+prop_ackTrip = property $ do
+ x <- forAll Generator.ackGen
+ tripping x encode eitherDecode
+
+prop_transitMsgTrip :: Property
+prop_transitMsgTrip = property $ do
+ x <- forAll Generator.transitMsgGen
+ tripping x encode eitherDecode
+
+prop_transitAckTrip :: Property
+prop_transitAckTrip = property $ do
+ x <- forAll Generator.transitAckGen
+ tripping x encode eitherDecode
+
+messagesRoundTripTests :: IO Bool
+messagesRoundTripTests =
+ checkSequential $ Group "Messages"
+ [ ("prop_abilityTrip", prop_abilityTrip)
+ , ("prop_hintTrip", prop_hintTrip)
+ , ("prop_connectionHintTrip", prop_connectionHintTrip)
+ , ("prop_ackTrip", prop_ackTrip)
+ , ("prop_transitMsgTrip", prop_transitMsgTrip)
+ , ("prop_transitAckTrip", prop_transitAckTrip)
+ ]
+
diff --git a/tests/PipelineTests.hs b/tests/PipelineTests.hs
new file mode 100644
--- /dev/null
+++ b/tests/PipelineTests.hs
@@ -0,0 +1,74 @@
+module PipelineTests
+ ( tests
+ )
+where
+
+import Protolude hiding (putByteString, Selector)
+
+import Test.Hspec
+import Conduit ((.|))
+
+import qualified Crypto.Saltine.Class as Saltine
+import qualified Crypto.Saltine.Core.SecretBox as SecretBox
+import qualified Data.Conduit as C
+import qualified Data.Conduit.Binary as CB
+import qualified Data.Conduit.Serialization.Binary as CSB
+import qualified Data.ByteString as BS
+
+import Data.Binary (Put)
+import Data.Binary.Put (putWord32be, putByteString)
+
+import Transit.Internal.Pipeline
+import Transit.Internal.Crypto (CryptoError)
+
+tests :: IO ()
+tests = hspec $ do
+ describe "assembleRecordC tests" $ do
+ it "tests assembleRecordC with a short bytestring input" $ do
+ let str = "hello" :: ByteString
+ xs <- liftIO $ C.runConduitRes $
+ CSB.sourcePut (putChunk str)
+ .| assembleRecordC
+ .| CB.isolate (BS.length str)
+ .| CB.sinkLbs
+ xs `shouldBe` (toS str)
+
+ describe "decryptC tests" $ do
+ it "tests a encryptC/decryptC round trip" $ do
+ let key = fromMaybe (panic "cannot decode key") $
+ Saltine.decode ("0123456789abcdef0123456789abcdef" :: ByteString)
+ plaintext = "foobar" :: ByteString
+ xs <- liftIO (C.runConduitRes $
+ CSB.sourcePut (putByteString plaintext)
+ .| encryptC key
+ .| assembleRecordC
+ .| decryptC key
+ .| CB.isolate (BS.length plaintext)
+ .| CB.sinkLbs)
+ xs `shouldBe` (toS plaintext)
+
+ it "throws CryptoError when a wrong nonce is encountered" $ do
+ -- create a packet with a non-zero nonce concatenated with
+ -- random input. Feed it as a source into decryptC and feed
+ -- output into a sinkLbs. This should throw a BadNonce
+ -- exception, as decryptC expects a nonce/sequence number of 0.
+ let nonce = Saltine.nudge Saltine.zero :: SecretBox.Nonce
+ key = fromMaybe (panic "cannot decode key") $
+ Saltine.decode ("0123456789abcdef0123456789abcdef" :: ByteString)
+ nonceBytes = Saltine.encode nonce
+ plaintext = "foobar" :: ByteString
+ packet = nonceBytes <> plaintext
+ liftIO (C.runConduitRes $
+ CSB.sourcePut (putByteString packet)
+ .| decryptC key
+ .| CB.isolate (BS.length packet)
+ .| CB.sinkLbs)
+ `shouldThrow` cryptoError
+ where
+ putChunk :: ByteString -> Put
+ putChunk s = do
+ let strlen = BS.length s
+ putWord32be (fromIntegral @Int strlen)
+ putByteString s
+ cryptoError :: Selector CryptoError
+ cryptoError = const True
diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs
new file mode 100644
--- /dev/null
+++ b/tests/ProtocolTests.hs
@@ -0,0 +1,32 @@
+module ProtocolTests
+ ( tests
+ )
+where
+
+import Protolude
+import Test.Hspec
+import qualified Crypto.Saltine.Class as Saltine
+import qualified Data.ByteString as BS
+
+import qualified MagicWormhole
+
+import Transit.Internal.Peer
+
+tests :: IO ()
+tests = hspec $ do
+ describe "sender handshake tests" $ do
+ it "sender handshake for a fixed key" $ do
+ let skey = (fromMaybe (panic "error decoding bytestring into secretbox key") $ Saltine.decode (toS @Text @ByteString "12345678901234567890123456789012"))
+ makeSenderHandshake skey `shouldBe` (toS @Text @ByteString "transit sender 8114b57043e22ca82f05b3aa21612bbcd403e6aa9b11e4a336dd749771775fa1 ready\n\n")
+ it "receiver handshake for a fixed key" $ do
+ let rkey = (fromMaybe (panic "error decoding bytestring into secretbox key") $ Saltine.decode (toS @Text @ByteString "12345678901234567890123456789012"))
+ makeReceiverHandshake rkey `shouldBe` (toS @Text @ByteString "transit receiver 3b0d65f31e63b490b4edc13cf27a8b09cfb53c479f8ab67bc984e9f392ea28f4 ready\n\n")
+ it "sender relay handshake for a given key" $ do
+ sidea <- generateTransitSide
+ let skey = (fromMaybe (panic "error decoding bytestring into secretbox key") $ Saltine.decode (toS @Text @ByteString "12345678901234567890123456789012"))
+ MagicWormhole.Side s1 = sidea
+ makeRelayHandshake skey sidea `shouldBe` (toS @Text @ByteString "please relay 24655fa61c1df5e320ee34d85417de170bcd5d31f69778600c2e3f78f2bd12b4 for side " <> (toS @Text @ByteString s1) <> "\n")
+ it "sender relay handshake length" $ do
+ sidea <- generateTransitSide
+ let skey = (fromMaybe (panic "error decoding bytestring into secretbox key") $ Saltine.decode (toS @Text @ByteString "12345678901234567890123456789012"))
+ BS.length (makeRelayHandshake skey sidea) `shouldBe` (BS.length (toS @Text @ByteString "please relay for side \n") + 32*2 + 8*2)
diff --git a/wordlist.txt b/wordlist.txt
new file mode 100644
--- /dev/null
+++ b/wordlist.txt
@@ -0,0 +1,256 @@
+00 aardvark adroitness
+01 absurd adviser
+02 accrue aftermath
+03 acme aggregate
+04 adrift alkali
+05 adult almighty
+06 afflict amulet
+07 ahead amusement
+08 aimless antenna
+09 Algol applicant
+0A allow Apollo
+0B alone armistice
+0C ammo article
+0D ancient asteroid
+0E apple Atlantic
+0F artist atmosphere
+10 assume autopsy
+11 Athens Babylon
+12 atlas backwater
+13 Aztec barbecue
+14 baboon belowground
+15 backfield bifocals
+16 backward bodyguard
+17 banjo bookseller
+18 beaming borderline
+19 bedlamp bottomless
+1A beehive Bradbury
+1B beeswax bravado
+1C befriend Brazilian
+1D Belfast breakaway
+1E berserk Burlington
+1F billiard businessman
+20 bison butterfat
+21 blackjack Camelot
+22 blockade candidate
+23 blowtorch cannonball
+24 bluebird Capricorn
+25 bombast caravan
+26 bookshelf caretaker
+27 brackish celebrate
+28 breadline cellulose
+29 breakup certify
+2A brickyard chambermaid
+2B briefcase Cherokee
+2C Burbank Chicago
+2D button clergyman
+2E buzzard coherence
+2F cement combustion
+30 chairlift commando
+31 chatter company
+32 checkup component
+33 chisel concurrent
+34 choking confidence
+35 chopper conformist
+36 Christmas congregate
+37 clamshell consensus
+38 classic consulting
+39 classroom corporate
+3A cleanup corrosion
+3B clockwork councilman
+3C cobra crossover
+3D commence crucifix
+3E concert cumbersome
+3F cowbell customer
+40 crackdown Dakota
+41 cranky decadence
+42 crowfoot December
+43 crucial decimal
+44 crumpled designing
+45 crusade detector
+46 cubic detergent
+47 dashboard determine
+48 deadbolt dictator
+49 deckhand dinosaur
+4A dogsled direction
+4B dragnet disable
+4C drainage disbelief
+4D dreadful disruptive
+4E drifter distortion
+4F dropper document
+50 drumbeat embezzle
+51 drunken enchanting
+52 Dupont enrollment
+53 dwelling enterprise
+54 eating equation
+55 edict equipment
+56 egghead escapade
+57 eightball Eskimo
+58 endorse everyday
+59 endow examine
+5A enlist existence
+5B erase exodus
+5C escape fascinate
+5D exceed filament
+5E eyeglass finicky
+5F eyetooth forever
+60 facial fortitude
+61 fallout frequency
+62 flagpole gadgetry
+63 flatfoot Galveston
+64 flytrap getaway
+65 fracture glossary
+66 framework gossamer
+67 freedom graduate
+68 frighten gravity
+69 gazelle guitarist
+6A Geiger hamburger
+6B glitter Hamilton
+6C glucose handiwork
+6D goggles hazardous
+6E goldfish headwaters
+6F gremlin hemisphere
+70 guidance hesitate
+71 hamlet hideaway
+72 highchair holiness
+73 hockey hurricane
+74 indoors hydraulic
+75 indulge impartial
+76 inverse impetus
+77 involve inception
+78 island indigo
+79 jawbone inertia
+7A keyboard infancy
+7B kickoff inferno
+7C kiwi informant
+7D klaxon insincere
+7E locale insurgent
+7F lockup integrate
+80 merit intention
+81 minnow inventive
+82 miser Istanbul
+83 Mohawk Jamaica
+84 mural Jupiter
+85 music leprosy
+86 necklace letterhead
+87 Neptune liberty
+88 newborn maritime
+89 nightbird matchmaker
+8A Oakland maverick
+8B obtuse Medusa
+8C offload megaton
+8D optic microscope
+8E orca microwave
+8F payday midsummer
+90 peachy millionaire
+91 pheasant miracle
+92 physique misnomer
+93 playhouse molasses
+94 Pluto molecule
+95 preclude Montana
+96 prefer monument
+97 preshrunk mosquito
+98 printer narrative
+99 prowler nebula
+9A pupil newsletter
+9B puppy Norwegian
+9C python October
+9D quadrant Ohio
+9E quiver onlooker
+9F quota opulent
+A0 ragtime Orlando
+A1 ratchet outfielder
+A2 rebirth Pacific
+A3 reform pandemic
+A4 regain Pandora
+A5 reindeer paperweight
+A6 rematch paragon
+A7 repay paragraph
+A8 retouch paramount
+A9 revenge passenger
+AA reward pedigree
+AB rhythm Pegasus
+AC ribcage penetrate
+AD ringbolt perceptive
+AE robust performance
+AF rocker pharmacy
+B0 ruffled phonetic
+B1 sailboat photograph
+B2 sawdust pioneer
+B3 scallion pocketful
+B4 scenic politeness
+B5 scorecard positive
+B6 Scotland potato
+B7 seabird processor
+B8 select provincial
+B9 sentence proximate
+BA shadow puberty
+BB shamrock publisher
+BC showgirl pyramid
+BD skullcap quantity
+BE skydive racketeer
+BF slingshot rebellion
+C0 slowdown recipe
+C1 snapline recover
+C2 snapshot repellent
+C3 snowcap replica
+C4 snowslide reproduce
+C5 solo resistor
+C6 southward responsive
+C7 soybean retraction
+C8 spaniel retrieval
+C9 spearhead retrospect
+CA spellbind revenue
+CB spheroid revival
+CC spigot revolver
+CD spindle sandalwood
+CE spyglass sardonic
+CF stagehand Saturday
+D0 stagnate savagery
+D1 stairway scavenger
+D2 standard sensation
+D3 stapler sociable
+D4 steamship souvenir
+D5 sterling specialist
+D6 stockman speculate
+D7 stopwatch stethoscope
+D8 stormy stupendous
+D9 sugar supportive
+DA surmount surrender
+DB suspense suspicious
+DC sweatband sympathy
+DD swelter tambourine
+DE tactics telephone
+DF talon therapist
+E0 tapeworm tobacco
+E1 tempest tolerance
+E2 tiger tomorrow
+E3 tissue torpedo
+E4 tonic tradition
+E5 topmost travesty
+E6 tracker trombonist
+E7 transit truncated
+E8 trauma typewriter
+E9 treadmill ultimate
+EA Trojan undaunted
+EB trouble underfoot
+EC tumor unicorn
+ED tunnel unify
+EE tycoon universe
+EF uncut unravel
+F0 unearth upcoming
+F1 unwind vacancy
+F2 uproot vagabond
+F3 upset vertigo
+F4 upshot Virginia
+F5 vapor visitor
+F6 village vocalist
+F7 virus voyager
+F8 Vulcan warranty
+F9 waffle Waterloo
+FA wallet whimsical
+FB watchword Wichita
+FC wayside Wilmington
+FD willow Wyoming
+FE woodlark yesteryear
+FF Zulu Yucatan