A => .gitignore +3 -0
@@ 1,3 @@
+dist/
+dist-newstyle/
+config.dhall
A => COPYING +661 -0
@@ 1,661 @@
+ GNU AFFERO GENERAL PUBLIC LICENSE
+ Version 3, 19 November 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The GNU Affero General Public License is a free, copyleft license for
+software and other kinds of works, specifically designed to ensure
+cooperation with the community in the case of network server software.
+
+ The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works. By contrast,
+our General Public Licenses are intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains free
+software for all its users.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+them if you wish), that you receive source code or can get it if you
+want it, that you can change the software or use pieces of it in new
+free programs, and that you know you can do these things.
+
+ Developers that use our General Public Licenses protect your rights
+with two steps: (1) assert copyright on the software, and (2) offer
+you this License which gives you legal permission to copy, distribute
+and/or modify the software.
+
+ A secondary benefit of defending all users' freedom is that
+improvements made in alternate versions of the program, if they
+receive widespread use, become available for other developers to
+incorporate. Many developers of free software are heartened and
+encouraged by the resulting cooperation. However, in the case of
+software used on network servers, this result may fail to come about.
+The GNU General Public License permits making a modified version and
+letting the public access it on a server without ever releasing its
+source code to the public.
+
+ The GNU Affero General Public License is designed specifically to
+ensure that, in such cases, the modified source code becomes available
+to the community. It requires the operator of a network server to
+provide the source code of the modified version running there to the
+users of that server. Therefore, public use of a modified version, on
+a publicly accessible server, gives the public access to the source
+code of the modified version.
+
+ An older license, called the Affero General Public License and
+published by Affero, was designed to accomplish similar goals. This is
+a different license, not a version of the Affero GPL, but Affero has
+released a new version of the Affero GPL which permits relicensing under
+this license.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ TERMS AND CONDITIONS
+
+ 0. Definitions.
+
+ "This License" refers to version 3 of the GNU Affero General Public License.
+
+ "Copyright" also means copyright-like laws that apply to other kinds of
+works, such as semiconductor masks.
+
+ "The Program" refers to any copyrightable work licensed under this
+License. Each licensee is addressed as "you". "Licensees" and
+"recipients" may be individuals or organizations.
+
+ To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of an
+exact copy. The resulting work is called a "modified version" of the
+earlier work or a work "based on" the earlier work.
+
+ A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+ To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy. Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+ To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies. Mere interaction with a user through
+a computer network, with no transfer of a copy, is not conveying.
+
+ An interactive user interface displays "Appropriate Legal Notices"
+to the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License. If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+ 1. Source Code.
+
+ The "source code" for a work means the preferred form of the work
+for making modifications to it. "Object code" means any non-source
+form of a work.
+
+ A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+ The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form. A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+ The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities. However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work. For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+ The Corresponding Source need not include anything that users
+can regenerate automatically from other parts of the Corresponding
+Source.
+
+ The Corresponding Source for a work in source code form is that
+same work.
+
+ 2. Basic Permissions.
+
+ All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met. This License explicitly affirms your unlimited
+permission to run the unmodified Program. The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work. This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+ You may make, run and propagate covered works that you do not
+convey, without conditions so long as your license otherwise remains
+in force. You may convey covered works to others for the sole purpose
+of having them make modifications exclusively for you, or provide you
+with facilities for running those works, provided that you comply with
+the terms of this License in conveying all material for which you do
+not control copyright. Those thus making or running the covered works
+for you must do so exclusively on your behalf, under your direction
+and control, on terms that prohibit them from making any copies of
+your copyrighted material outside their relationship with you.
+
+ Conveying under any other circumstances is permitted solely under
+the conditions stated below. Sublicensing is not allowed; section 10
+makes it unnecessary.
+
+ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+ No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+ When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such circumvention
+is effected by exercising rights under this License with respect to
+the covered work, and you disclaim any intention to limit operation or
+modification of the work as a means of enforcing, against the work's
+users, your or third parties' legal rights to forbid circumvention of
+technological measures.
+
+ 4. Conveying Verbatim Copies.
+
+ You may convey verbatim copies of the Program's source code as you
+receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+ You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+ 5. Conveying Modified Source Versions.
+
+ You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these conditions:
+
+ a) The work must carry prominent notices stating that you modified
+ it, and giving a relevant date.
+
+ b) The work must carry prominent notices stating that it is
+ released under this License and any conditions added under section
+ 7. This requirement modifies the requirement in section 4 to
+ "keep intact all notices".
+
+ c) You must license the entire work, as a whole, under this
+ License to anyone who comes into possession of a copy. This
+ License will therefore apply, along with any applicable section 7
+ additional terms, to the whole of the work, and all its parts,
+ regardless of how they are packaged. This License gives no
+ permission to license the work in any other way, but it does not
+ invalidate such permission if you have separately received it.
+
+ d) If the work has interactive user interfaces, each must display
+ Appropriate Legal Notices; however, if the Program has interactive
+ interfaces that do not display Appropriate Legal Notices, your
+ work need not make them do so.
+
+ A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit. Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+ 6. Conveying Non-Source Forms.
+
+ You may convey a covered work in object code form under the terms
+of sections 4 and 5, provided that you also convey the
+machine-readable Corresponding Source under the terms of this License,
+in one of these ways:
+
+ a) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by the
+ Corresponding Source fixed on a durable physical medium
+ customarily used for software interchange.
+
+ b) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by a
+ written offer, valid for at least three years and valid for as
+ long as you offer spare parts or customer support for that product
+ model, to give anyone who possesses the object code either (1) a
+ copy of the Corresponding Source for all the software in the
+ product that is covered by this License, on a durable physical
+ medium customarily used for software interchange, for a price no
+ more than your reasonable cost of physically performing this
+ conveying of source, or (2) access to copy the
+ Corresponding Source from a network server at no charge.
+
+ c) Convey individual copies of the object code with a copy of the
+ written offer to provide the Corresponding Source. This
+ alternative is allowed only occasionally and noncommercially, and
+ only if you received the object code with such an offer, in accord
+ with subsection 6b.
+
+ d) Convey the object code by offering access from a designated
+ place (gratis or for a charge), and offer equivalent access to the
+ Corresponding Source in the same way through the same place at no
+ further charge. You need not require recipients to copy the
+ Corresponding Source along with the object code. If the place to
+ copy the object code is a network server, the Corresponding Source
+ may be on a different server (operated by you or a third party)
+ that supports equivalent copying facilities, provided you maintain
+ clear directions next to the object code saying where to find the
+ Corresponding Source. Regardless of what server hosts the
+ Corresponding Source, you remain obligated to ensure that it is
+ available for as long as needed to satisfy these requirements.
+
+ e) Convey the object code using peer-to-peer transmission, provided
+ you inform other peers where the object code and Corresponding
+ Source of the work are being offered to the general public at no
+ charge under subsection 6d.
+
+ A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+ A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal, family,
+or household purposes, or (2) anything designed or sold for incorporation
+into a dwelling. In determining whether a product is a consumer product,
+doubtful cases shall be resolved in favor of coverage. For a particular
+product received by a particular user, "normally used" refers to a
+typical or common use of that class of product, regardless of the status
+of the particular user or of the way in which the particular user
+actually uses, or expects or is expected to use, the product. A product
+is a consumer product regardless of whether the product has substantial
+commercial, industrial or non-consumer uses, unless such uses represent
+the only significant mode of use of the product.
+
+ "Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to install
+and execute modified versions of a covered work in that User Product from
+a modified version of its Corresponding Source. The information must
+suffice to ensure that the continued functioning of the modified object
+code is in no case prevented or interfered with solely because
+modification has been made.
+
+ If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information. But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+ The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or updates
+for a work that has been modified or installed by the recipient, or for
+the User Product in which it has been modified or installed. Access to a
+network may be denied when the modification itself materially and
+adversely affects the operation of the network or violates the rules and
+protocols for communication across the network.
+
+ Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+ 7. Additional Terms.
+
+ "Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law. If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+ When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it. (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.) You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+ Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders of
+that material) supplement the terms of this License with terms:
+
+ a) Disclaiming warranty or limiting liability differently from the
+ terms of sections 15 and 16 of this License; or
+
+ b) Requiring preservation of specified reasonable legal notices or
+ author attributions in that material or in the Appropriate Legal
+ Notices displayed by works containing it; or
+
+ c) Prohibiting misrepresentation of the origin of that material, or
+ requiring that modified versions of such material be marked in
+ reasonable ways as different from the original version; or
+
+ d) Limiting the use for publicity purposes of names of licensors or
+ authors of the material; or
+
+ e) Declining to grant rights under trademark law for use of some
+ trade names, trademarks, or service marks; or
+
+ f) Requiring indemnification of licensors and authors of that
+ material by anyone who conveys the material (or modified versions of
+ it) with contractual assumptions of liability to the recipient, for
+ any liability that these contractual assumptions directly impose on
+ those licensors and authors.
+
+ All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10. If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term. If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+ If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+ Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions;
+the above requirements apply either way.
+
+ 8. Termination.
+
+ You may not propagate or modify a covered work except as expressly
+provided under this License. Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+ However, if you cease all violation of this License, then your
+license from a particular copyright holder is reinstated (a)
+provisionally, unless and until the copyright holder explicitly and
+finally terminates your license, and (b) permanently, if the copyright
+holder fails to notify you of the violation by some reasonable means
+prior to 60 days after the cessation.
+
+ Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+ Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License. If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+ 9. Acceptance Not Required for Having Copies.
+
+ You are not required to accept this License in order to receive or
+run a copy of the Program. Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance. However,
+nothing other than this License grants you permission to propagate or
+modify any covered work. These actions infringe copyright if you do
+not accept this License. Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+ 10. Automatic Licensing of Downstream Recipients.
+
+ Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License. You are not responsible
+for enforcing compliance by third parties with this License.
+
+ An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations. If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+ You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License. For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+ 11. Patents.
+
+ A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based. The
+work thus licensed is called the contributor's "contributor version".
+
+ A contributor's "essential patent claims" are all patent claims
+owned or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version. For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+ Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+ In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement). To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+ If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients. "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+ If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+ A patent license is "discriminatory" if it does not include within
+the scope of its coverage, prohibits the exercise of, or is
+conditioned on the non-exercise of one or more of the rights that are
+specifically granted under this License. You may not convey a covered
+work if you are a party to an arrangement with a third party that is
+in the business of distributing software, under which you make payment
+to the third party based on the extent of your activity of conveying
+the work, and under which the third party grants, to any of the
+parties who would receive the covered work from you, a discriminatory
+patent license (a) in connection with copies of the covered work
+conveyed by you (or copies made from those copies), or (b) primarily
+for and in connection with specific products or compilations that
+contain the covered work, unless you entered into that arrangement,
+or that patent license was granted, prior to 28 March 2007.
+
+ Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+ 12. No Surrender of Others' Freedom.
+
+ If conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot convey a
+covered work so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you may
+not convey it at all. For example, if you agree to terms that obligate you
+to collect a royalty for further conveying from those to whom you convey
+the Program, the only way you could satisfy both those terms and this
+License would be to refrain entirely from conveying the Program.
+
+ 13. Remote Network Interaction; Use with the GNU General Public License.
+
+ Notwithstanding any other provision of this License, if you modify the
+Program, your modified version must prominently offer all users
+interacting with it remotely through a computer network (if your version
+supports such interaction) an opportunity to receive the Corresponding
+Source of your version by providing access to the Corresponding Source
+from a network server at no charge, through some standard or customary
+means of facilitating copying of software. This Corresponding Source
+shall include the Corresponding Source for any work covered by version 3
+of the GNU General Public License that is incorporated pursuant to the
+following paragraph.
+
+ Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU General Public License into a single
+combined work, and to convey the resulting work. The terms of this
+License will continue to apply to the part which is the covered work,
+but the work with which it is combined will remain governed by version
+3 of the GNU General Public License.
+
+ 14. Revised Versions of this License.
+
+ The Free Software Foundation may publish revised and/or new versions of
+the GNU Affero General Public License from time to time. Such new versions
+will be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+ Each version is given a distinguishing version number. If the
+Program specifies that a certain numbered version of the GNU Affero General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation. If the Program does not specify a version number of the
+GNU Affero General Public License, you may choose any version ever published
+by the Free Software Foundation.
+
+ If the Program specifies that a proxy can decide which future
+versions of the GNU Affero General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+ Later license versions may give you additional or different
+permissions. However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+ 15. Disclaimer of Warranty.
+
+ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+ 16. Limitation of Liability.
+
+ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+ 17. Interpretation of Sections 15 and 16.
+
+ If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+state the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU Affero General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU Affero General Public License for more details.
+
+ You should have received a copy of the GNU Affero General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+Also add information on how to contact you by electronic and paper mail.
+
+ If your software can interact with users remotely through a computer
+network, you should also make sure that it provides a way for users to
+get its source. For example, if your program is a web application, its
+interface could display a "Source" link that leads users to an archive
+of the code. There are many ways you could offer source, and different
+solutions will be better for different programs; see section 13 for the
+specific requirements.
+
+ You should also get your employer (if you work as a programmer) or school,
+if any, to sign a "copyright disclaimer" for the program, if necessary.
+For more information on this, and how to apply and follow the GNU AGPL, see
+<http://www.gnu.org/licenses/>.
A => Config.hs +60 -0
@@ 1,60 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
+
+module Config where
+
+import Prelude ()
+import BasicPrelude
+import Control.Error (headZ)
+import Network.HostAndPort (maybeHostAndPort)
+import System.IO.Unsafe (unsafePerformIO)
+
+import qualified Database.Redis as Redis
+import qualified Dhall
+import qualified Dhall.Core as Dhall
+import qualified Network.Protocol.XMPP as XMPP
+import qualified Network.Socket as Socket
+
+import Util
+import qualified RedisURL
+
+data Config = Config {
+ component :: ComponentConfig,
+ server :: ServerConfig,
+ serverRoot :: Text,
+ redis :: Redis.ConnectInfo
+} deriving (Dhall.Generic, Dhall.FromDhall, Show)
+
+data ServerConfig = ServerConfig { host :: Socket.HostName, port :: Socket.PortNumber } deriving (Dhall.Generic, Dhall.FromDhall, Show)
+data ComponentConfig = ComponentConfig { jid :: XMPP.JID, secret :: Text } deriving (Dhall.Generic, Dhall.FromDhall, Show)
+
+instance Dhall.FromDhall XMPP.JID where
+ autoWith _ = Dhall.Decoder {
+ Dhall.extract = \(Dhall.TextLit (Dhall.Chunks _ txt)) ->
+ maybe (Dhall.extractError $ s"Invalid JID") pure $ XMPP.parseJID txt,
+ Dhall.expected = pure Dhall.Text
+ }
+
+instance Dhall.FromDhall Socket.PortNumber where
+ autoWith _ = Dhall.Decoder {
+ Dhall.extract = \(Dhall.NaturalLit nat) -> pure $ fromIntegral nat,
+ Dhall.expected = pure Dhall.Natural
+ }
+
+instance Dhall.FromDhall Socket.SockAddr where
+ autoWith _ = Dhall.Decoder {
+ Dhall.extract = \(Dhall.TextLit (Dhall.Chunks _ txt)) -> maybe (Dhall.extractError $ s"Invalid Socket Address") pure $ do
+ Just (host, Just port) <- return $ maybeHostAndPort (textToString txt)
+ -- This is not a great idea, but I'm lazy today and I really just want to parse IP addresses, which is a pure operation
+ unsafePerformIO $ fmap (fmap Socket.addrAddress . headZ) $ Socket.getAddrInfo Nothing (Just host) (Just port)
+ ,
+ Dhall.expected = pure Dhall.Text
+ }
+
+instance Dhall.FromDhall Redis.ConnectInfo where
+ autoWith _ = Dhall.Decoder {
+ Dhall.extract = \(Dhall.TextLit (Dhall.Chunks _ txt)) ->
+ either (Dhall.extractError . tshow) pure $ RedisURL.parseConnectInfo $ textToString txt
+ ,
+ Dhall.expected = pure Dhall.Text
+ }
A => DB.hs +112 -0
@@ 1,112 @@
+module DB (DB, Key(..), mk, byJid, byTel, get, getEnum, del, set, expire, setEnum, sadd, srem, smembers, foldKeysM, hset, hdel, hgetall) where
+
+import Prelude ()
+import BasicPrelude
+import Control.Error (ExceptT(..))
+import GHC.Stack (HasCallStack)
+import Network.Protocol.XMPP (JID(..))
+
+import UnexceptionalIO (Unexceptional)
+import qualified Database.Redis as Redis
+import qualified Data.ByteString as BS
+import qualified Data.Text.Encoding as T
+
+import Util
+
+newtype DB = DB {
+ redis :: Redis.Connection
+}
+
+newtype Key = Key [String] deriving (Eq)
+
+mk :: Redis.ConnectInfo -> IO DB
+mk redisCI = DB <$> Redis.checkedConnect redisCI
+
+-- | 0xFF is invalid everywhere in UTF8 and is the CBOR "break" byte
+redisKey :: Key -> ByteString
+redisKey (Key key) = intercalate (BS.singleton 0xff) $ map (encodeUtf8 . fromString) key
+
+redisParseKey :: ByteString -> Key
+redisParseKey = Key . map (textToString . T.decodeUtf8) . BS.split 0xff
+
+runRedisChecked :: (Unexceptional m, HasCallStack) => DB -> Redis.Redis (Either Redis.Reply a) -> ExceptT Redis.Reply m a
+runRedisChecked db action =
+ ExceptT $ fromIO_ $ Redis.runRedis (redis db) action
+
+get :: (Unexceptional m, HasCallStack) => DB -> Key -> ExceptT Redis.Reply m (Maybe Text)
+get db key = (fmap.fmap) T.decodeUtf8 $
+ runRedisChecked db (Redis.get (redisKey key))
+
+getEnum :: (Unexceptional m, HasCallStack, Enum a) => DB -> Key -> ExceptT Redis.Reply m (Maybe a)
+getEnum db key = (fmap.fmap) (toEnum . read . T.decodeUtf8) $
+ runRedisChecked db (Redis.get (redisKey key))
+
+del :: (Unexceptional m, HasCallStack) => DB -> Key -> ExceptT Redis.Reply m ()
+del db key = void $ runRedisChecked db $ Redis.del [redisKey key]
+
+set :: (Unexceptional m, HasCallStack) => DB -> Key -> Text -> ExceptT Redis.Reply m ()
+set db key val =
+ void $ runRedisChecked db $ Redis.set (redisKey key) (encodeUtf8 val)
+
+expire :: (Unexceptional m, HasCallStack) => DB -> Key -> Integer -> ExceptT Redis.Reply m ()
+expire db key seconds =
+ -- True if set, False if key didn't exist, but actually I don't care
+ void $ runRedisChecked db $ Redis.expire (redisKey key) seconds
+
+setEnum :: (Unexceptional m, HasCallStack, Enum a) => DB -> Key -> a -> ExceptT Redis.Reply m ()
+setEnum db key val =
+ void $ runRedisChecked db $ Redis.set (redisKey key) (encodeUtf8 $ tshow $ fromEnum val)
+
+sadd :: (Unexceptional m, HasCallStack) => DB -> Key -> [Text] -> ExceptT Redis.Reply m ()
+sadd _ _ [] = return ()
+sadd db key new =
+ void $ runRedisChecked db $ Redis.sadd (redisKey key) (map encodeUtf8 new)
+
+srem :: (Unexceptional m, HasCallStack) => DB -> Key -> [Text] -> ExceptT Redis.Reply m ()
+srem db key toremove =
+ void $ runRedisChecked db $ Redis.srem (redisKey key) (map encodeUtf8 toremove)
+
+smembers :: (Unexceptional m, HasCallStack) => DB -> Key -> ExceptT Redis.Reply m [Text]
+smembers db key =
+ map T.decodeUtf8 <$> runRedisChecked db (Redis.smembers (redisKey key))
+
+-- | Encode Just txt as UTF8 txt and Nothing as "\xf6"
+-- This is invalid UTF8, so there is no overlap. It is also the CBOR value for null
+redisMaybe :: Maybe Text -> ByteString
+redisMaybe (Just txt) = encodeUtf8 txt
+redisMaybe Nothing = BS.singleton 0xf6
+
+readRedisMaybe :: ByteString -> Maybe Text
+readRedisMaybe bytes
+ | bytes == BS.singleton 0xf6 = Nothing
+ | otherwise = Just $ T.decodeUtf8 bytes
+
+hset :: (Unexceptional m, HasCallStack) => DB -> Key -> [(Text, Maybe Text)] -> ExceptT Redis.Reply m ()
+hset _ _ [] = return ()
+hset db key newitems =
+ void $ runRedisChecked db (Redis.hmset (redisKey key) (map (encodeUtf8 *** redisMaybe) newitems))
+
+hdel :: (Unexceptional m, HasCallStack) => DB -> Key -> [Text] -> ExceptT Redis.Reply m ()
+hdel db key toremove =
+ void $ runRedisChecked db (Redis.hdel (redisKey key) (map encodeUtf8 toremove))
+
+hgetall :: (Unexceptional m, HasCallStack) => DB -> Key -> ExceptT Redis.Reply m [(Text, Maybe Text)]
+hgetall db key =
+ map (T.decodeUtf8 *** readRedisMaybe) <$>
+ runRedisChecked db (Redis.hgetall (redisKey key))
+
+foldKeysM :: (Unexceptional m, HasCallStack) => DB -> Key -> b -> (b -> Key -> ExceptT Redis.Reply m b) -> ExceptT Redis.Reply m b
+foldKeysM db (Key prefix) z f = go Redis.cursor0 z
+ where
+ pattern = redisKey $ Key $ prefix ++ ["*"]
+ go cursor acc = do
+ (cursor', keys) <- runRedisChecked db $ Redis.scanOpts cursor (Redis.ScanOpts (Just pattern) (Just 100))
+ acc' <- foldM f acc $ map redisParseKey keys
+ if cursor' == Redis.cursor0 then return acc' else
+ go cursor' acc'
+
+byJid :: JID -> [String] -> Key
+byJid jid subkey = Key $ textToString (bareTxt jid) : subkey
+
+byTel :: Text -> [String] -> Key
+byTel tel subkey = Key $ textToString tel : subkey
A => Main.hs +354 -0
@@ 1,354 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Main (main) where
+
+import Prelude ()
+import BasicPrelude
+import System.Exit (die)
+import Control.Error (justZ)
+
+import Network.HTTP.Req (runReq, req, defaultHttpConfig, (/:), jsonResponse, oAuth2Bearer, https, POST(..), PUT(..), HttpException, ReqBodyJson(..), JsonResponse, responseBody)
+import Network.HTTP.Types.Status (ok200, badRequest400)
+import Network.Protocol.XMPP (XMPP, IQ(..), Message(..), JID(..), IQType(..), ReceivedStanza(ReceivedIQ, ReceivedMessage))
+import UnexceptionalIO (Unexceptional)
+import qualified Data.Aeson as Aeson
+import qualified Data.Conduit as Conduit
+import qualified Data.Conduit.Attoparsec as Conduit
+import qualified Data.XML.Types as XML
+import qualified Dhall
+import qualified Network.Protocol.XMPP as XMPP
+import qualified Network.Wai as Wai
+import qualified Network.Wai.Cli as Wai
+import qualified Network.Wai.Conduit as Wai
+import qualified UnexceptionalIO as UIO
+
+import Model
+import Config hiding (component, serverRoot, redis)
+import Util
+import DB (DB)
+import qualified DB
+
+sendMessage :: (Unexceptional m) =>
+ Text
+ -> Text
+ -> Text
+ -> RCSMessageWithContactInfo
+ -> m (Either HttpException (JsonResponse RCSMessageResponse))
+sendMessage serverRoot bearer channelId payload
+ | Just _ <- status (rCSMessage payload),
+ Just id <- msgId (rCSMessage payload) = do
+ UIO.fromIO' (error . show) $ runReq defaultHttpConfig $ do
+ req
+ PUT
+ (https serverRoot /: s"iotac" /: s"channel" /: s"v0" /: channelId /: s"messages" /: id /: s"status")
+ (ReqBodyJson payload)
+ jsonResponse
+ (oAuth2Bearer $ encodeUtf8 bearer)
+sendMessage serverRoot bearer channelId payload =
+ UIO.fromIO' (error . show) $ runReq defaultHttpConfig $ do
+ req
+ POST
+ (https serverRoot /: s"iotac" /: s"channel" /: s"v0" /: channelId /: s"messages")
+ (ReqBodyJson payload)
+ jsonResponse
+ (oAuth2Bearer $ encodeUtf8 bearer)
+
+data Context = Context {
+ serverRoot :: Text,
+ db :: DB,
+ componentJid :: JID
+}
+
+incomingStanza :: Context -> XMPP.ReceivedStanza -> XMPP ()
+
+incomingStanza Context {} (ReceivedMessage Message {
+ messageType = XMPP.MessageError
+}) = return () -- ignore for now
+
+-- Incoming message to a tel
+incomingStanza Context { db, serverRoot } (ReceivedMessage m@Message {
+ messageID = xmppId,
+ messageFrom = Just from,
+ messageTo = Just (JID { jidNode = Just tel })
+}) = do
+ reg <- runRedisInXMPP $ DB.hgetall db (DB.byJid from ["ecrio_registration"])
+ let fromReg k = fromMaybe mempty $ join $ lookup k reg
+ let payload = RCSMessageWithContactInfo
+ (RCSMessage {
+ msgId = received m <|> displayed m,
+ status = fmap (const Delivered) (received m) <|> fmap (const Displayed) (displayed m),
+ timestamp = Nothing,
+ isTyping = Just $ if isComposing m then Active else Idle,
+ textMessage = getBody m,
+ fileMessage = mkFileMessage <$>
+ getChildText (s"{jabber:x:oob}url") (
+ XML.elementChildren =<<
+ XML.isNamed (s"{jabber:x:oob}x") =<< XMPP.messagePayloads m
+ )
+ })
+ (MessageContact { userContact = XMPP.strNode tel })
+ (Channel { provider = s"rbm", accessToken = Just $ fromReg (s"accessToken"), identifier = Nothing })
+ result <- sendMessage serverRoot (fromReg (s"bearer")) (fromReg (s"tel")) payload
+ case result of
+ Left e -> logE "sendMessage" e
+ Right r -> do
+ let k = [maybe mempty textToString $ msgId $ responseRCSMessage $ responseBody r]
+ runRedisInXMPP (DB.set db (DB.byJid from k) (fromMaybe mempty xmppId))
+ runRedisInXMPP (DB.expire db (DB.byJid from k) (60*60*24))
+ logI "sendMessage" $ responseRCSMessage $ responseBody r
+
+-- Disco info for the bare domain
+incomingStanza _ (ReceivedIQ iq@IQ {
+ iqType = IQGet,
+ iqTo = Just (JID { jidNode = Nothing }),
+ iqPayload = Just p
+}) | [q] <- XML.isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p = do
+ XMPP.putStanza $ iqReply iq $ Just $
+ XML.Element (s"{http://jabber.org/protocol/disco#info}query")
+ (map
+ (\node -> (s"{http://jabber.org/protocol/disco#info}node", [XML.ContentText node]))
+ (maybeToList $ XML.attributeText (s"node") q)
+ )
+ [
+ XML.NodeElement $ XML.Element (s"{http://jabber.org/protocol/disco#info}identity") [
+ (s"category", [s"gateway"]),
+ (s"type", [s"rcs"]),
+ (s"name", [s"SGX Ecrio RCS"])
+ ] [],
+ XML.NodeElement $ XML.Element (s"{http://jabber.org/protocol/disco#info}feature") [
+ (s"var", [s"http://jabber.org/protocol/disco#info"])
+ ] [],
+ XML.NodeElement $ XML.Element (s"{http://jabber.org/protocol/disco#info}feature") [
+ (s"var", [s"jabber:iq:register"])
+ ] []
+ ]
+
+-- Disco info for a tel
+incomingStanza _ (ReceivedIQ iq@IQ {
+ iqType = IQGet,
+ iqTo = Just (JID { jidNode = Just _ }),
+ iqPayload = Just p
+}) | [q] <- XML.isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p = do
+ XMPP.putStanza $ iqReply iq $ Just $
+ XML.Element (s"{http://jabber.org/protocol/disco#info}query")
+ (map
+ (\node -> (s"{http://jabber.org/protocol/disco#info}node", [XML.ContentText node]))
+ (maybeToList $ XML.attributeText (s"node") q)
+ )
+ [
+ XML.NodeElement $ XML.Element (s"{http://jabber.org/protocol/disco#info}identity") [
+ (s"category", [s"client"]),
+ (s"type", [s"phone"]),
+ (s"name", [s"SGX Ecrio RCS"])
+ ] [],
+ XML.NodeElement $ XML.Element (s"{http://jabber.org/protocol/disco#info}feature") [
+ (s"var", [s"http://jabber.org/protocol/disco#info"])
+ ] [],
+ XML.NodeElement $ XML.Element (s"{http://jabber.org/protocol/disco#info}feature") [
+ (s"var", [s"http://jabber.org/protocol/chatstates"])
+ ] []
+ ]
+
+-- Regigration (IBR) get form
+incomingStanza Context { db } (ReceivedIQ iq@IQ {
+ iqType = IQGet,
+ iqTo = Just (JID { jidNode = Nothing }),
+ iqFrom = Just from,
+ iqPayload = Just p
+}) | [_] <- XML.isNamed (fromString "{jabber:iq:register}query") p = do
+ reg <- runRedisInXMPP $ DB.hgetall db (DB.byJid from ["ecrio_registration"])
+ XMPP.putStanza $ iqReply iq $ Just $
+ XML.Element (s"{jabber:iq:register}query") []
+ ([
+ XML.NodeElement $ XML.Element (s"{jabber:iq:register}phone") [] $
+ justZ $ XML.NodeContent . XML.ContentText <$> join (lookup (s"tel") reg),
+ XML.NodeElement $ XML.Element (s"{jabber:iq:register}password") [] [],
+ XML.NodeElement $ XML.Element (s"{jabber:iq:register}key") [] []
+ ] ++ if null reg then [] else [XML.NodeElement $ XML.Element (s"{jabber:iq:register}registered") [] []])
+
+-- Regigration (IBR) handle submit
+incomingStanza Context { db } (ReceivedIQ iq@IQ {
+ iqType = IQSet,
+ iqTo = Just (JID { jidNode = Nothing }),
+ iqFrom = Just from,
+ iqPayload = Just p
+}) | [q] <- XML.isNamed (fromString "{jabber:iq:register}query") p = do
+ if isRemove iq then do
+ reg <- runRedisInXMPP $ DB.hgetall db (DB.byJid from ["ecrio_registration"])
+ let fromReg k = fromMaybe mempty $ join $ lookup k reg
+ runRedisInXMPP $ DB.del db (DB.byJid from ["ecrio_registration"])
+ runRedisInXMPP $ DB.del db (DB.byTel (fromReg $ s"tel") ["jid"])
+ else do
+ let tel = getChildText (s"{jabber:iq:register}phone") (XML.elementChildren q)
+ runRedisInXMPP $ DB.hset db (DB.byJid from ["ecrio_registration"]) [
+ (s"tel", tel),
+ (s"accessToken", getChildText (s"{jabber:iq:register}password") (XML.elementChildren q)),
+ (s"bearer", getChildText (s"{jabber:iq:register}key") (XML.elementChildren q))
+ ]
+ forM_ tel $ \telT ->
+ runRedisInXMPP $ DB.set db (DB.byTel telT ["jid"]) (bareTxt from)
+ XMPP.putStanza $ iqReply iq Nothing
+
+-- Must reply to all IQ with at least an error
+incomingStanza _ (ReceivedIQ iq@IQ { iqType = typ })
+ | typ `elem` [IQGet, IQSet] =
+ XMPP.putStanza $ iq {
+ iqTo = iqFrom iq,
+ iqFrom = iqTo iq,
+ iqType = IQError,
+ iqPayload = Just $ XML.Element (s"{jabber:component:accept}error")
+ [(s"{jabber:component:accept}type", [s"cancel"])]
+ [XML.NodeElement $ XML.Element (s"{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable") [] []]
+ }
+
+incomingStanza _ _ = return ()
+
+delay :: JID -> Maybe Text -> [XML.Element]
+delay _ Nothing = []
+delay jid (Just timestamp) = [
+ XML.Element (s"{urn:xmpp:delay}delay") [
+ (s"from", [XML.ContentText $ bareTxt jid]),
+ (s"stamp", [XML.ContentText timestamp])
+ ]
+ [s"RCS Network"]
+ ]
+
+chatstate :: Maybe TypingStatus -> [XML.Element]
+chatstate Nothing = []
+chatstate (Just Active) = [XML.Element (s"{http://jabber.org/protocol/chatstates}composing") [] []]
+chatstate (Just Idle) = [XML.Element (s"{http://jabber.org/protocol/chatstates}paused") [] []]
+
+body :: Maybe Text -> [XML.Element]
+body Nothing = []
+body (Just txt) = [
+ XML.Element (s"{jabber:component:accept}body") []
+ [XML.NodeContent $ XML.ContentText txt]
+ ]
+
+attachment :: Maybe FileMessage -> [XML.Element]
+attachment (Just (FileMessage { fileUrl = url })) = [
+ XML.Element (s"{jabber:x:oob}x") [] [
+ XML.NodeElement $ XML.Element (s"{jabber:x:oob}url") []
+ [XML.NodeContent $ XML.ContentText url]
+ ],
+ XML.Element (s"{jabber:component:accept}body") []
+ [XML.NodeContent $ XML.ContentText url]
+ ]
+attachment _ = []
+
+createMessageStanza :: JID -> JID -> Maybe Text -> RCSMessageWithContactInfo -> XMPP.Message
+createMessageStanza componentJid to _ RCSMessageWithContactInfo {
+ rCSMessage = RCSMessage {
+ msgId,
+ status = Nothing,
+ timestamp,
+ isTyping,
+ textMessage,
+ fileMessage
+ },
+ messageContact = MessageContact {
+ userContact = fromTel
+ }
+} = (XMPP.emptyMessage XMPP.MessageChat) {
+ messageID = msgId,
+ messageTo = Just to,
+ messageFrom = Just from,
+ messagePayloads = delay from timestamp ++ chatstate isTyping ++
+ body textMessage ++ attachment fileMessage
+}
+ where
+ Just from = XMPP.parseJID $ fromTel ++ s"@" ++ bareTxt componentJid
+
+createMessageStanza componentJid to (Just msgId) RCSMessageWithContactInfo {
+ rCSMessage = RCSMessage {
+ status = Just Delivered,
+ timestamp
+ },
+ messageContact = MessageContact {
+ userContact = fromTel
+ }
+} = (XMPP.emptyMessage XMPP.MessageChat) {
+ messageTo = Just to,
+ messageFrom = Just from,
+ messagePayloads = delay from timestamp ++ [
+ XML.Element (s"{urn:xmpp:receipts}received")
+ [(s"id", [XML.ContentText msgId])] []
+ ]
+}
+ where
+ Just from = XMPP.parseJID $ fromTel ++ s"@" ++ bareTxt componentJid
+
+createMessageStanza componentJid to (Just msgId) RCSMessageWithContactInfo {
+ rCSMessage = RCSMessage {
+ status = Just Displayed,
+ timestamp
+ },
+ messageContact = MessageContact {
+ userContact = fromTel
+ }
+} = (XMPP.emptyMessage XMPP.MessageChat) {
+ messageTo = Just to,
+ messageFrom = Just from,
+ messagePayloads = delay from timestamp ++ [
+ XML.Element (s"{urn:xmpp:chat-markers:0}displayed")
+ [(s"id", [XML.ContentText msgId])] []
+ ]
+}
+ where
+ Just from = XMPP.parseJID $ fromTel ++ s"@" ++ bareTxt componentJid
+
+createMessageStanza _ _ _ rcs = error $ "TODO: " ++ show rcs
+
+sendRCSToXMPP :: Context -> Text -> RCSMessageWithContactInfo -> XMPP ()
+sendRCSToXMPP Context { componentJid, db } toTel rcs = do
+ mjid <- (XMPP.parseJID =<<) <$> runRedisInXMPP (DB.get db (DB.byTel toTel ["jid"]))
+ case mjid of
+ Just jid -> do
+ mid <- runRedisInXMPP (DB.get db (DB.byJid jid [maybe mempty textToString $ msgId $ rCSMessage rcs]))
+ XMPP.putStanza $ createMessageStanza componentJid jid mid rcs
+ Nothing -> logI "sendRCSToXMPP" ("No JID found for", toTel)
+
+web :: Context -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> XMPP Wai.ResponseReceived
+web ctx req handler = (>>= fromIO_ . handler) $ do
+ let [token, _, toTel] = Wai.pathInfo req
+ body <- fmap Aeson.fromJSON <$> Wai.sourceRequestBody req `Conduit.connect` Conduit.sinkParserEither Aeson.json
+ case body of
+ Right (Aeson.Success message) -> do
+ sendRCSToXMPP ctx toTel message
+ return $ Wai.responseLBS ok200 [] mempty
+ e -> logE "web" e >> return (Wai.responseLBS badRequest400 [] mempty)
+
+component :: Context -> XMPP ()
+component ctx = do
+ void $ flip forkFinallyXMPP (either (logE "web" . show) return) $ do
+ xmppSession <- XMPP.getSession
+ fromIO_ $ Wai.defWaiMain $
+ \req resp -> either (error . show) return =<<
+ XMPP.runXMPP xmppSession (web ctx req resp)
+ forever $ flip XMPP.catchE (\e -> do
+ logE "component read EXCEPTION" e
+ liftIO $ case e of
+ XMPP.TransportError _ -> die "Component connection gone"
+ XMPP.InvalidStanza el
+ | not $ null $ XML.isNamed (s"{http://etherx.jabber.org/streams}error") el ->
+ die "Component connection error"
+ _ -> return ()
+ ) (XMPP.getStanza >>= \s ->
+ void $ forkFinallyXMPP
+ (incomingStanza ctx s)
+ (either (logE "incomingStanza" . show) return)
+ )
+
+main :: IO ()
+main = do
+ (config:_) <- getArgs
+ (Config
+ (ComponentConfig componentJid secret)
+ (Config.ServerConfig host port)
+ serverRoot
+ redis
+ ) <- Dhall.input Dhall.auto config
+ ctx <- Context <$> pure serverRoot <*> DB.mk redis <*> pure componentJid
+ logI "Starting..." ()
+ logE "runComponent ENDED" =<<
+ XMPP.runComponent (XMPP.Server componentJid host port) secret (component ctx)
A => Model.hs +130 -0
@@ 1,130 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Model where
+
+import Prelude ()
+import BasicPrelude
+
+import Data.Aeson
+import GHC.Generics (Generic)
+import Data.Text as T
+
+data RCSMessageWithContactInfo = RCSMessageWithContactInfo {
+ rCSMessage :: RCSMessage,
+ messageContact :: MessageContact,
+ channel :: Channel
+} deriving (Generic, Show)
+
+instance ToJSON RCSMessageWithContactInfo where
+ toEncoding = genericToEncoding (defaultOptions {
+ fieldLabelModifier = \label -> if label == "rCSMessage" then "RCSMessage" else label
+ })
+
+instance FromJSON RCSMessageWithContactInfo where
+ parseJSON = genericParseJSON (defaultOptions {
+ fieldLabelModifier = \label -> if label == "rCSMessage" then "RCSMessage" else label
+ })
+
+newtype RCSMessageResponse = RCSMessageResponse {
+ responseRCSMessage :: RCSMessage
+} deriving (Generic, Show)
+
+instance ToJSON RCSMessageResponse where
+ toEncoding = genericToEncoding (defaultOptions {
+ fieldLabelModifier = \label -> if label == "responseRCSMessage" then "RCSMessage" else label
+ })
+
+instance FromJSON RCSMessageResponse where
+ parseJSON = genericParseJSON (defaultOptions {
+ fieldLabelModifier = \label -> if label == "responseRCSMessage" then "RCSMessage" else label
+ })
+
+data RCSMessage = RCSMessage {
+ msgId :: Maybe Text,
+ status :: Maybe MessageStatus,
+ timestamp :: Maybe Text,
+ isTyping :: Maybe TypingStatus,
+ textMessage :: Maybe Text,
+ fileMessage :: Maybe FileMessage
+} deriving (Generic, Show)
+
+instance ToJSON RCSMessage where
+ toEncoding = genericToEncoding (defaultOptions {
+ omitNothingFields = True
+ })
+
+instance FromJSON RCSMessage
+
+data FileMessage = FileMessage {
+ thumbnailFileName :: Maybe Text,
+ thumbnailUrl :: Maybe Text,
+ thumbnailMIMEType :: Maybe Text,
+ thumbnailFileSize :: Maybe Int,
+ fileName :: Maybe Text,
+ fileUrl :: Text,
+ fileMIMEType :: Maybe Text,
+ fileSize :: Maybe Int
+} deriving (Generic, Show)
+
+mkFileMessage :: Text -> FileMessage
+mkFileMessage url = FileMessage {
+ thumbnailFileName = Nothing,
+ thumbnailUrl = Nothing,
+ thumbnailMIMEType = Nothing,
+ thumbnailFileSize = Nothing,
+ fileName = Nothing,
+ fileUrl = url,
+ fileMIMEType = Nothing,
+ fileSize = Nothing
+ }
+
+instance ToJSON FileMessage where
+ toEncoding = genericToEncoding (defaultOptions {
+ omitNothingFields = True
+ })
+
+instance FromJSON FileMessage
+
+newtype MessageContact = MessageContact {
+ userContact :: Text
+} deriving (Generic, Show)
+
+instance ToJSON MessageContact where
+ toEncoding = genericToEncoding defaultOptions
+
+instance FromJSON MessageContact
+
+data Channel = Channel {
+ provider :: Text,
+ accessToken :: Maybe Text,
+ identifier :: Maybe Text
+} deriving (Generic, Show)
+
+instance ToJSON Channel where
+ toEncoding = genericToEncoding defaultOptions
+
+instance FromJSON Channel
+
+data TypingStatus = Active | Idle deriving (Generic, Show)
+
+instance ToJSON TypingStatus where
+ toEncoding = genericToEncoding (defaultOptions {
+ constructorTagModifier = textToString . T.toLower . fromString
+ })
+
+instance FromJSON TypingStatus where
+ parseJSON = genericParseJSON (defaultOptions {
+ constructorTagModifier = textToString . T.toLower . fromString
+ })
+
+data MessageStatus = Pending | Sent | Delivered | Displayed | Failed deriving (Generic, Show)
+
+instance ToJSON MessageStatus where
+ toEncoding = genericToEncoding (defaultOptions {
+ constructorTagModifier = textToString . T.toLower . fromString
+ })
+
+instance FromJSON MessageStatus where
+ parseJSON = genericParseJSON (defaultOptions {
+ constructorTagModifier = textToString . T.toLower . fromString
+ })
A => RedisURL.hs +93 -0
@@ 1,93 @@
+{-
+Copyright (c)2011, Falko Peters
+Some modifications by Stephen Paul Weber
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Falko Peters nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+-}
+module RedisURL (parseConnectInfo) where
+
+import Prelude ()
+import BasicPrelude
+import Control.Error.Util (note)
+import Database.Redis (ConnectInfo(..), defaultConnectInfo, PortID(..))
+import Network.HTTP.Base
+import Network.HTTP.Types (parseSimpleQuery)
+import Network.URI (URI, parseURI, uriPath, uriScheme, uriQuery)
+import Text.Read (readMaybe)
+
+import qualified Data.ByteString.Char8 as C8
+
+parseConnectInfo :: String -> Either String ConnectInfo
+parseConnectInfo url = do
+ uri <- note "Invalid URI" $ parseURI url
+ case uriScheme uri of
+ "redis:" -> parseRedisScheme uri
+ "unix:" -> parseUnixScheme uri
+ _ -> Left "Invalid scheme"
+
+parseUnixScheme :: URI -> Either String ConnectInfo
+parseUnixScheme uri =
+ return defaultConnectInfo
+ { connectHost = ""
+ , connectPort = UnixSocket path
+ , connectAuth = C8.pack <$> (password =<< uriAuth)
+ , connectDatabase = db
+ }
+ where
+ path = case uriPath uri of
+ ('/':_) -> uriPath uri
+ _ -> '/' : uriPath uri
+ db = fromMaybe 0 $ readMaybe . textToString . decodeUtf8 =<<
+ lookup (encodeUtf8 $ fromString "db") query
+ query = parseSimpleQuery (encodeUtf8 $ fromString $ uriQuery uri)
+ uriAuth = parseURIAuthority $ uriToAuthorityString uri
+
+parseRedisScheme :: URI -> Either String ConnectInfo
+parseRedisScheme uri = do
+ uriAuth <- note "Missing or invalid Authority"
+ $ parseURIAuthority
+ $ uriToAuthorityString uri
+
+ let h = host uriAuth
+ let dbNumPart = dropWhile (== '/') (uriPath uri)
+
+ db <- if null dbNumPart
+ then return $ connectDatabase defaultConnectInfo
+ else note ("Invalid port: " <> dbNumPart) $ readMaybe dbNumPart
+
+ return defaultConnectInfo
+ { connectHost = if null h
+ then connectHost defaultConnectInfo
+ else h
+ , connectPort = maybe (connectPort defaultConnectInfo)
+ (PortNumber . fromIntegral) $ port uriAuth
+ , connectAuth = C8.pack <$> password uriAuth
+ , connectDatabase = db
+ }
A => Util.hs +96 -0
@@ 1,96 @@
+module Util where
+
+import Prelude ()
+import BasicPrelude
+import Control.Concurrent
+import GHC.Stack (HasCallStack)
+import Control.Error (ExceptT, exceptT, justZ)
+import Data.Void (absurd)
+import Data.Time (getCurrentTime)
+import System.Exit (ExitCode)
+import qualified Control.Exception as Ex
+
+import Text.Pretty.Simple (pPrint)
+import UnexceptionalIO (Unexceptional)
+import qualified UnexceptionalIO as UIO
+import qualified Database.Redis as Redis
+import Network.Protocol.XMPP (XMPP)
+import qualified Network.Protocol.XMPP as XMPP
+import qualified Data.XML.Types as XML
+
+instance Unexceptional XMPP.XMPP where
+ lift = liftIO . UIO.lift
+
+s :: (IsString s) => String -> s
+s = fromString
+
+logI :: (HasCallStack, Show a, Unexceptional m) => String -> a -> m ()
+logI tag x = fromIO_ $ do
+ time <- getCurrentTime
+ putStr (tshow time ++ s" " ++ fromString tag ++ s" :: ") >> pPrint x
+
+logE :: (HasCallStack, Show a, Unexceptional m) => String -> a -> m ()
+logE = logI
+
+fromIO_ :: (HasCallStack, Unexceptional m) => IO a -> m a
+fromIO_ = fmap (either absurd id) . UIO.fromIO' (error . show)
+
+-- Re-throws all by ThreadKilled async to parent thread
+-- Makes sync child exceptions async in parent, which is a bit sloppy
+forkXMPP :: XMPP.XMPP () -> XMPP.XMPP ThreadId
+forkXMPP kid = do
+ parent <- liftIO myThreadId
+ forkFinallyXMPP kid (either (handler parent) (const $ return ()))
+ where
+ handler parent e
+ | Just Ex.ThreadKilled <- castException e = return ()
+ | Just (Ex.SomeAsyncException _) <- castException e = throwTo parent e
+ | Just e <- castException e = throwTo parent (e :: ExitCode)
+ | otherwise = throwTo parent (ChildThreadError e)
+
+forkFinallyXMPP :: XMPP.XMPP () -> (Either SomeException () -> IO ()) -> XMPP.XMPP ThreadId
+forkFinallyXMPP kid handler = do
+ session <- XMPP.getSession
+ liftIO $ forkFinally (void $ XMPP.runXMPP session kid) handler
+
+castException :: (Ex.Exception e1, Ex.Exception e2) => e1 -> Maybe e2
+castException = Ex.fromException . Ex.toException
+
+newtype ChildThreadError = ChildThreadError SomeException deriving (Show, Typeable)
+
+instance Ex.Exception ChildThreadError where
+ toException = Ex.asyncExceptionToException
+ fromException = Ex.asyncExceptionFromException
+
+getChildText :: XML.Name -> [XML.Element] -> Maybe Text
+getChildText name kids = listToMaybe $ fmap (mconcat . XML.elementText) (XML.isNamed name =<< kids)
+
+getBody :: XMPP.Message -> Maybe Text
+getBody = getChildText (s"{jabber:component:accept}body") . XMPP.messagePayloads
+
+iqReply :: XMPP.IQ -> Maybe XML.Element -> XMPP.IQ
+iqReply iq payload = iq {
+ XMPP.iqType = XMPP.IQResult,
+ XMPP.iqFrom = XMPP.iqTo iq,
+ XMPP.iqTo = XMPP.iqFrom iq,
+ XMPP.iqPayload = payload
+}
+
+isComposing :: XMPP.Message -> Bool
+isComposing m = not $ null $ XML.isNamed (s"{http://jabber.org/protocol/chatstates}composing") =<< XMPP.messagePayloads m
+
+received :: XMPP.Message -> Maybe Text
+received m = XML.attributeText (s"id") =<< listToMaybe (XML.isNamed (s"{urn:xmpp:receipts}received") =<< XMPP.messagePayloads m)
+
+displayed :: XMPP.Message -> Maybe Text
+displayed m = XML.attributeText (s"id") =<< listToMaybe (XML.isNamed (s"{urn:xmpp:chat-markers:0}displayed") =<< XMPP.messagePayloads m)
+
+isRemove :: XMPP.IQ -> Bool
+isRemove iq = not $ null $ XML.isNamed (s"{jabber:iq:register}remove") =<< XML.elementChildren =<< justZ (XMPP.iqPayload iq)
+
+bareTxt :: XMPP.JID -> Text
+bareTxt (XMPP.JID (Just node) domain _) = mconcat [XMPP.strNode node, s"@", XMPP.strDomain domain]
+bareTxt (XMPP.JID Nothing domain _) = XMPP.strDomain domain
+
+runRedisInXMPP :: ExceptT Redis.Reply XMPP a -> XMPP a
+runRedisInXMPP = exceptT (XMPP.throwE . XMPP.TransportError . tshow) return
A => sgx-ecrio.cabal +38 -0
@@ 1,38 @@
+cabal-version: 2.4
+name: sgx-ecrio
+version: 0.1.0.0
+synopsis: Sopranica Gateway to XMPP for Ecrio
+license: AGPL-3.0-only
+author: Stephen Paul Weber
+maintainer: singpolyma@singpolyma.net
+
+executable sgx-ecrio
+ main-is: Main.hs
+ other-modules: Model, Config, Util, RedisURL, DB
+ ghc-options: -Wall -Wno-tabs -Wno-orphans -Wno-name-shadowing -O
+ build-depends: base ^>=4.15.1.0,
+ aeson,
+ bytestring,
+ basic-prelude,
+ text,
+ dhall,
+ errors,
+ req,
+ unexceptionalio,
+ network,
+ network-protocol-xmpp,
+ HostAndPort,
+ time,
+ xml-types,
+ pretty-simple,
+ hedis,
+ network-uri,
+ HTTP,
+ http-types,
+ wai,
+ wai-cli,
+ conduit-extra,
+ wai-conduit,
+ conduit
+ hs-source-dirs: .
+ default-language: Haskell2010