diff --git a/License.txt b/License.txt deleted file mode 100644 --- a/License.txt +++ /dev/null @@ -1,674 +0,0 @@ - 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/Network/Protocol/XMPP.hs b/Network/Protocol/XMPP.hs deleted file mode 100644 --- a/Network/Protocol/XMPP.hs +++ /dev/null @@ -1,73 +0,0 @@ --- Copyright (C) 2010-2011 John Millikin --- --- 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 --- 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 . - -module Network.Protocol.XMPP - ( - -- * JIDs - JID (..) - , Node - , Domain - , Resource - - , strNode - , strDomain - , strResource - - , parseJID - , formatJID - - -- * Stanzas - , Stanza - ( stanzaTo - , stanzaFrom - , stanzaID - , stanzaLang - , stanzaPayloads - ) - - , ReceivedStanza (..) - , Message (..) - , Presence (..) - , IQ (..) - , MessageType (..) - , PresenceType (..) - , IQType (..) - - , emptyMessage - , emptyPresence - , emptyIQ - - -- * The XMPP monad - , XMPP - , Server (..) - , Error (..) - , runClient - , runComponent - , putStanza - , getStanza - , bindJID - - -- ** Resuming sessions - , Session - , getSession - , runXMPP - ) where - -import Network.Protocol.XMPP.Client -import Network.Protocol.XMPP.Component -import Network.Protocol.XMPP.Connections -import Network.Protocol.XMPP.JID -import Network.Protocol.XMPP.Monad -import Network.Protocol.XMPP.Stanza diff --git a/Network/Protocol/XMPP/Client.hs b/Network/Protocol/XMPP/Client.hs deleted file mode 100644 --- a/Network/Protocol/XMPP/Client.hs +++ /dev/null @@ -1,147 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- Copyright (C) 2010-2011 John Millikin --- --- 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 --- 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 . - -module Network.Protocol.XMPP.Client - ( runClient - , bindJID - ) where - -import Control.Monad ((>=>)) -import Control.Monad.Error (throwError) -import Control.Monad.Trans (liftIO) -import Data.ByteString (ByteString) -import Data.Text (Text) -import Network (connectTo) -import qualified System.IO as IO - -import qualified Network.Protocol.XMPP.Client.Authentication as A -import qualified Network.Protocol.XMPP.Connections as C -import qualified Network.Protocol.XMPP.Client.Features as F -import qualified Network.Protocol.XMPP.Handle as H -import qualified Network.Protocol.XMPP.JID as J -import qualified Network.Protocol.XMPP.Monad as M -import qualified Network.Protocol.XMPP.XML as X -import Network.Protocol.XMPP.ErrorT -import Network.Protocol.XMPP.Stanza - -runClient :: C.Server - -> J.JID -- ^ Client JID - -> Text -- ^ Username - -> Text -- ^ Password - -> M.XMPP a - -> IO (Either M.Error a) -runClient server jid username password xmpp = do - -- Open a TCP connection - let C.Server sjid host port = server - rawHandle <- connectTo host port - IO.hSetBuffering rawHandle IO.NoBuffering - let handle = H.PlainHandle rawHandle - - -- Open the initial stream and authenticate - M.startXMPP handle "jabber:client" $ do - features <- newStream sjid - tryTLS sjid features $ \tlsFeatures -> do - let mechanisms = authenticationMechanisms tlsFeatures - A.authenticate mechanisms jid sjid username password - M.restartXMPP Nothing (newStream sjid >> xmpp) - -newStream :: J.JID -> M.XMPP [F.Feature] -newStream jid = do - M.putBytes (C.xmlHeader "jabber:client" jid) - void (M.readEvents C.startOfStream) - F.parseFeatures `fmap` M.getElement - -tryTLS :: J.JID -> [F.Feature] -> ([F.Feature] -> M.XMPP a) -> M.XMPP a -tryTLS sjid features m - | not (streamSupportsTLS features) = m features - | otherwise = do - M.putElement xmlStartTLS - void M.getElement - h <- M.getHandle - eitherTLS <- liftIO (runErrorT (H.startTLS h)) - case eitherTLS of - Left err -> throwError (M.TransportError err) - Right tls -> M.restartXMPP (Just tls) (newStream sjid >>= m) - -authenticationMechanisms :: [F.Feature] -> [ByteString] -authenticationMechanisms = step where - step [] = [] - step (f:fs) = case f of - (F.FeatureSASL ms) -> ms - _ -> step fs - --- | Send a @\@ message for the given 'J.JID', returning the server's reply. In --- most cases the reply will be the same as the input. However, if the input has no --- 'J.Resource', the returned 'J.JID' will contain a generated 'J.Resource'. --- --- Clients must bind a 'J.JID' before sending any 'Stanza's. -bindJID :: J.JID -> M.XMPP J.JID -bindJID jid = do - -- Bind - M.putStanza (bindStanza (J.jidResource jid)) - bindResult <- M.getStanza - let getJID = - X.elementChildren - >=> X.isNamed "{urn:ietf:params:xml:ns:xmpp-bind}jid" - >=> X.elementNodes - >=> X.isContent - >=> return . X.contentText - - let maybeJID = do - iq <- case bindResult of - ReceivedIQ x -> Just x - _ -> Nothing - payload <- iqPayload iq - - case getJID payload of - [] -> Nothing - (str:_) -> J.parseJID str - - returnedJID <- case maybeJID of - Just x -> return x - Nothing -> throwError (M.InvalidBindResult bindResult) - - -- Session - M.putStanza sessionStanza - void M.getStanza - - M.putStanza (emptyPresence PresenceAvailable) - void M.getStanza - - return returnedJID - -bindStanza :: Maybe J.Resource -> IQ -bindStanza resource = (emptyIQ IQSet) { iqPayload = Just payload } where - payload = X.element "{urn:ietf:params:xml:ns:xmpp-bind}bind" [] requested - requested = case fmap J.strResource resource of - Nothing -> [] - Just x -> [X.NodeElement (X.element "resource" [] [X.NodeContent (X.ContentText x)])] - -sessionStanza :: IQ -sessionStanza = (emptyIQ IQSet) { iqPayload = Just payload } where - payload = X.element "{urn:ietf:params:xml:ns:xmpp-session}session" [] [] - -streamSupportsTLS :: [F.Feature] -> Bool -streamSupportsTLS = any isStartTLS where - isStartTLS (F.FeatureStartTLS _) = True - isStartTLS _ = False - -xmlStartTLS :: X.Element -xmlStartTLS = X.element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] [] - -void :: Monad m => m a -> m () -void m = m >> return () diff --git a/Network/Protocol/XMPP/Client/Authentication.hs b/Network/Protocol/XMPP/Client/Authentication.hs deleted file mode 100644 --- a/Network/Protocol/XMPP/Client/Authentication.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveDataTypeable #-} - --- Copyright (C) 2009-2011 John Millikin --- --- 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 --- 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 . - -module Network.Protocol.XMPP.Client.Authentication - ( Result (..) - , authenticate - ) where - -import qualified Control.Exception as Exc -import Control.Monad (when, (>=>)) -import Control.Monad.IO.Class (MonadIO, liftIO) -import qualified Control.Monad.Error as E -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 -import qualified Data.Text -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) -import Data.Typeable (Typeable) -import qualified Network.Protocol.SASL.GNU as SASL - -import qualified Network.Protocol.XMPP.Monad as M -import qualified Network.Protocol.XMPP.XML as X -import Network.Protocol.XMPP.JID (JID, formatJID, jidResource) - -data Result = Success | Failure - deriving (Show, Eq) - -data AuthException = XmppError M.Error | SaslError Text - deriving (Typeable, Show) - -instance Exc.Exception AuthException - -authenticate :: [ByteString] -- ^ Mechanisms - -> JID -- ^ User JID - -> JID -- ^ Server JID - -> Text -- ^ Username - -> Text -- ^ Password - -> M.XMPP () -authenticate xmppMechanisms userJID serverJID username password = xmpp where - mechanisms = map SASL.Mechanism xmppMechanisms - authz = formatJID (userJID { jidResource = Nothing }) - hostname = formatJID serverJID - - xmpp = do - ctx <- M.getSession - res <- liftIO . Exc.try . SASL.runSASL $ do - suggested <- SASL.clientSuggestMechanism mechanisms - case suggested of - Nothing -> saslError "No supported authentication mechanism" - Just mechanism -> authSasl ctx mechanism - case res of - Right Success -> return () - Right Failure -> E.throwError M.AuthenticationFailure - Left (XmppError err) -> E.throwError err - Left (SaslError err) -> E.throwError (M.AuthenticationError err) - - authSasl ctx mechanism = do - let (SASL.Mechanism mechBytes) = mechanism - sessionResult <- SASL.runClient mechanism $ do - SASL.setProperty SASL.PropertyAuthzID (encodeUtf8 authz) - SASL.setProperty SASL.PropertyAuthID (encodeUtf8 username) - SASL.setProperty SASL.PropertyPassword (encodeUtf8 password) - SASL.setProperty SASL.PropertyService "xmpp" - SASL.setProperty SASL.PropertyHostname (encodeUtf8 hostname) - - (b64text, rc) <- SASL.step64 "" - putElement ctx $ X.element "{urn:ietf:params:xml:ns:xmpp-sasl}auth" - [("mechanism", Data.Text.pack (Data.ByteString.Char8.unpack mechBytes))] - [X.NodeContent (X.ContentText (Data.Text.pack (Data.ByteString.Char8.unpack b64text)))] - - case rc of - SASL.Complete -> saslFinish ctx - SASL.NeedsMore -> saslLoop ctx - - case sessionResult of - Right x -> return x - Left err -> saslError (Data.Text.pack (show err)) - -saslLoop :: M.Session -> SASL.Session Result -saslLoop ctx = do - elemt <- getElement ctx - let name = "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" - let getChallengeText = - X.isNamed name - >=> X.elementNodes - >=> X.isContent - >=> return . X.contentText - let challengeText = getChallengeText elemt - when (null challengeText) (saslError "Received empty challenge") - - (b64text, rc) <- SASL.step64 (Data.ByteString.Char8.pack (concatMap Data.Text.unpack challengeText)) - putElement ctx $ X.element "{urn:ietf:params:xml:ns:xmpp-sasl}response" - [] [X.NodeContent (X.ContentText (Data.Text.pack (Data.ByteString.Char8.unpack b64text)))] - case rc of - SASL.Complete -> saslFinish ctx - SASL.NeedsMore -> saslLoop ctx - -saslFinish :: M.Session -> SASL.Session Result -saslFinish ctx = do - elemt <- getElement ctx - let name = "{urn:ietf:params:xml:ns:xmpp-sasl}success" - let success = X.isNamed name elemt - return (if null success then Failure else Success) - -putElement :: M.Session -> X.Element -> SASL.Session () -putElement ctx elemt = liftIO $ do - res <- M.runXMPP ctx (M.putElement elemt) - case res of - Left err -> Exc.throwIO (XmppError err) - Right x -> return x - -getElement :: M.Session -> SASL.Session X.Element -getElement ctx = liftIO $ do - res <- M.runXMPP ctx M.getElement - case res of - Left err -> Exc.throwIO (XmppError err) - Right x -> return x - -saslError :: MonadIO m => Text -> m a -saslError = liftIO . Exc.throwIO . SaslError diff --git a/Network/Protocol/XMPP/Client/Features.hs b/Network/Protocol/XMPP/Client/Features.hs deleted file mode 100644 --- a/Network/Protocol/XMPP/Client/Features.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- Copyright (C) 2010-2011 John Millikin --- --- 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 --- 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 . - -module Network.Protocol.XMPP.Client.Features - ( Feature (..) - , parseFeatures - , parseFeature - ) where - -import Control.Arrow ((&&&)) -import qualified Data.ByteString.Char8 -import Data.ByteString (ByteString) -import qualified Data.Text -import qualified Network.Protocol.XMPP.XML as X - -data Feature = - FeatureStartTLS Bool - | FeatureSASL [ByteString] - | FeatureRegister - | FeatureBind - | FeatureSession - | FeatureUnknown X.Element - deriving (Show, Eq) - -parseFeatures :: X.Element -> [Feature] -parseFeatures e = - X.isNamed nameFeatures e - >>= X.elementChildren - >>= return . parseFeature - -parseFeature :: X.Element -> Feature -parseFeature elemt = feature where - unpackName = (maybe "" id . X.nameNamespace) &&& X.nameLocalName - feature = case unpackName (X.elementName elemt) of - ("urn:ietf:params:xml:ns:xmpp-tls", "starttls") -> parseFeatureTLS elemt - ("urn:ietf:params:xml:ns:xmpp-sasl", "mechanisms") -> parseFeatureSASL elemt - ("http://jabber.org/features/iq-register", "register") -> FeatureRegister - ("urn:ietf:params:xml:ns:xmpp-bind", "bind") -> FeatureBind - ("urn:ietf:params:xml:ns:xmpp-session", "session") -> FeatureSession - _ -> FeatureUnknown elemt - -parseFeatureTLS :: X.Element -> Feature -parseFeatureTLS _ = FeatureStartTLS True -- TODO: detect whether or not required - -parseFeatureSASL :: X.Element -> Feature -parseFeatureSASL e = FeatureSASL $ - X.elementChildren e - >>= X.isNamed nameMechanism - >>= X.elementNodes - >>= X.isContent - >>= return . Data.ByteString.Char8.pack . Data.Text.unpack . X.contentText - -nameMechanism :: X.Name -nameMechanism = "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" - -nameFeatures :: X.Name -nameFeatures = "{http://etherx.jabber.org/streams}features" diff --git a/Network/Protocol/XMPP/Component.hs b/Network/Protocol/XMPP/Component.hs deleted file mode 100644 --- a/Network/Protocol/XMPP/Component.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- Copyright (C) 2010 Stephan Maka --- Copyright (C) 2010-2011 John Millikin --- --- 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 --- 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 . - -module Network.Protocol.XMPP.Component - ( runComponent - ) where - -import Control.Monad (when) -import Control.Monad.Error (throwError) -import Data.Bits (shiftR, (.&.)) -import Data.Char (intToDigit) -import qualified Data.ByteString -import Data.ByteString (ByteString) -import qualified Data.Text -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) -import Network (connectTo) -import Network.Protocol.SASL.GNU (sha1) -import qualified System.IO as IO - -import qualified Network.Protocol.XMPP.Connections as C -import qualified Network.Protocol.XMPP.Handle as H -import qualified Network.Protocol.XMPP.Monad as M -import qualified Network.Protocol.XMPP.XML as X -import Network.Protocol.XMPP.JID (JID) - -runComponent :: C.Server - -> Text -- ^ Server secret - -> M.XMPP a - -> IO (Either M.Error a) -runComponent server password xmpp = do - let C.Server jid host port = server - rawHandle <- connectTo host port - IO.hSetBuffering rawHandle IO.NoBuffering - let handle = H.PlainHandle rawHandle - M.startXMPP handle "jabber:component:accept" $ do - streamID <- beginStream jid - authenticate streamID password - xmpp - -beginStream :: JID -> M.XMPP Text -beginStream jid = do - M.putBytes $ C.xmlHeader "jabber:component:accept" jid - events <- M.readEvents C.startOfStream - case parseStreamID $ last events of - Nothing -> throwError M.NoComponentStreamID - Just x -> return x - -parseStreamID :: X.Event -> Maybe Text -parseStreamID (X.EventBeginElement name attrs) = X.attributeText - "{jabber:component:accept}jid" - (X.Element name attrs []) -parseStreamID _ = Nothing - -authenticate :: Text -> Text -> M.XMPP () -authenticate streamID password = do - let bytes = buildSecret streamID password - let digest = showDigest (sha1 bytes) - M.putElement (X.element "handshake" [] [X.NodeContent (X.ContentText digest)]) - result <- M.getElement - let nameHandshake = "{jabber:component:accept}handshake" - when (null (X.isNamed nameHandshake result)) (throwError M.AuthenticationFailure) - -buildSecret :: Text -> Text -> ByteString -buildSecret sid password = encodeUtf8 (X.escape (Data.Text.append sid password)) - -showDigest :: ByteString -> Text -showDigest = Data.Text.pack . concatMap wordToHex . Data.ByteString.unpack where - wordToHex x = [hexDig (shiftR x 4), hexDig (x .&. 0xF)] - hexDig = intToDigit . fromIntegral diff --git a/Network/Protocol/XMPP/Connections.hs b/Network/Protocol/XMPP/Connections.hs deleted file mode 100644 --- a/Network/Protocol/XMPP/Connections.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- Copyright (C) 2010-2011 John Millikin --- --- 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 --- 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 . - -module Network.Protocol.XMPP.Connections - ( Server (..) - , xmlHeader - , startOfStream - , qnameStream - ) where - -import Network (HostName, PortID) -import Data.ByteString (ByteString) -import qualified Data.Text -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) - -import qualified Network.Protocol.XMPP.XML as X -import Network.Protocol.XMPP.JID (JID, formatJID) - -data Server = Server - { serverJID :: JID - , serverHostname :: HostName - , serverPort :: PortID - } - --- Since only the opening tag should be written, normal XML --- serialization cannot be used. Be careful to escape any embedded --- attributes. -xmlHeader :: Text -> JID -> ByteString -xmlHeader ns jid = encodeUtf8 header where - attr x = Data.Text.concat ["\"", X.escape x, "\""] - header = Data.Text.concat - [ "\n" - , "" - ] - -startOfStream :: Integer -> X.Event -> Bool -startOfStream depth event = case (depth, event) of - (1, (X.EventBeginElement elemName _)) -> qnameStream == elemName - _ -> False - -qnameStream :: X.Name -qnameStream = "{http://etherx.jabber.org/streams}stream" diff --git a/Network/Protocol/XMPP/ErrorT.hs b/Network/Protocol/XMPP/ErrorT.hs deleted file mode 100644 --- a/Network/Protocol/XMPP/ErrorT.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - --- Copyright (C) 2010-2011 John Millikin --- --- 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 --- 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 . - -module Network.Protocol.XMPP.ErrorT - ( ErrorT (..) - , mapErrorT - ) where - -import Control.Monad (liftM) -import Control.Monad.Fix (MonadFix, mfix) -import Control.Monad.Trans (MonadIO, liftIO) -import Control.Monad.Trans.Class (MonadTrans, lift) -import qualified Control.Monad.Error as E -import qualified Control.Monad.Reader as R - --- A custom version of ErrorT, without the 'Error' class restriction. - -newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) } - -instance Functor m => Functor (ErrorT e m) where - fmap f = ErrorT . fmap (fmap f) . runErrorT - -instance Monad m => Monad (ErrorT e m) where - return = ErrorT . return . Right - (>>=) m k = ErrorT $ do - x <- runErrorT m - case x of - Left l -> return (Left l) - Right r -> runErrorT (k r) - -instance Monad m => E.MonadError (ErrorT e m) where - type E.ErrorType (ErrorT e m) = e - throwError = ErrorT . return . Left - catchError m h = ErrorT $ do - x <- runErrorT m - case x of - Left l -> runErrorT (h l) - Right r -> return (Right r) - -instance MonadTrans (ErrorT e) where - lift = ErrorT . liftM Right - -instance R.MonadReader m => R.MonadReader (ErrorT e m) where - type R.EnvType (ErrorT e m) = R.EnvType m - ask = lift R.ask - local = mapErrorT . R.local - -instance MonadIO m => MonadIO (ErrorT e m) where - liftIO = lift . liftIO - -instance MonadFix m => MonadFix (ErrorT e m) where - mfix f = ErrorT $ mfix $ \ex -> runErrorT $ f $ case ex of - Right x -> x - _ -> error "empty mfix parameter" - -mapErrorT :: (m (Either e a) -> n (Either e' b)) - -> ErrorT e m a - -> ErrorT e' n b -mapErrorT f m = ErrorT (f (runErrorT m)) diff --git a/Network/Protocol/XMPP/Handle.hs b/Network/Protocol/XMPP/Handle.hs deleted file mode 100644 --- a/Network/Protocol/XMPP/Handle.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- Copyright (C) 2010-2011 John Millikin --- --- 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 --- 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 . - -module Network.Protocol.XMPP.Handle - ( Handle (..) - , startTLS - , hPutBytes - , hGetBytes - ) where - -import Control.Monad (when) -import qualified Control.Monad.Error as E -import Control.Monad.Trans (liftIO) -import qualified Data.ByteString -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy -import qualified Data.Text -import Data.Text (Text) -import qualified System.IO as IO -import qualified Network.Protocol.TLS.GNU as TLS -import Network.Protocol.XMPP.ErrorT - -data Handle = - PlainHandle IO.Handle - | SecureHandle IO.Handle TLS.Session - -liftTLS :: TLS.Session -> TLS.TLS a -> ErrorT Text IO a -liftTLS s = liftTLS' . TLS.runTLS s - -liftTLS' :: IO (Either TLS.Error a) -> ErrorT Text IO a -liftTLS' io = do - eitherX <- liftIO io - case eitherX of - Left err -> E.throwError (Data.Text.pack (show err)) - Right x -> return x - -startTLS :: Handle -> ErrorT Text IO Handle -startTLS (SecureHandle _ _) = E.throwError "Can't start TLS on a secure handle" -startTLS (PlainHandle h) = liftTLS' $ TLS.runClient (TLS.handleTransport h) $ do - TLS.setPriority [TLS.X509] - TLS.setCredentials =<< TLS.certificateCredentials - TLS.handshake - SecureHandle h `fmap` TLS.getSession - -hPutBytes :: Handle -> ByteString -> ErrorT Text IO () -hPutBytes (PlainHandle h) = liftIO . Data.ByteString.hPut h -hPutBytes (SecureHandle _ s) = liftTLS s . TLS.putBytes . toLazy where - toLazy bytes = Data.ByteString.Lazy.fromChunks [bytes] - -hGetBytes :: Handle -> Integer -> ErrorT Text IO ByteString -hGetBytes (PlainHandle h) n = liftIO (Data.ByteString.hGet h (fromInteger n)) -hGetBytes (SecureHandle h s) n = liftTLS s $ do - pending <- TLS.checkPending - let wait = IO.hWaitForInput h (- 1) >> return () - when (pending == 0) (liftIO wait) - lazy <- TLS.getBytes n - return (Data.ByteString.concat (Data.ByteString.Lazy.toChunks lazy)) diff --git a/Network/Protocol/XMPP/JID.hs b/Network/Protocol/XMPP/JID.hs deleted file mode 100644 --- a/Network/Protocol/XMPP/JID.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} - --- Copyright (C) 2010-2011 John Millikin --- --- 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 --- 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 . - -module Network.Protocol.XMPP.JID - ( JID (..) - , Node (..) - , Domain (..) - , Resource (..) - - , parseJID - , parseJID_ - , formatJID - ) where - -import qualified Data.Text -import Data.Text (Text) -import qualified Data.Text.IDN.StringPrep as SP -import Data.String (IsString, fromString) - -newtype Node = Node { strNode :: Text } -newtype Domain = Domain { strDomain :: Text } -newtype Resource = Resource { strResource :: Text } - -instance Show Node where - showsPrec d (Node x) = showParen (d > 10) $ - showString "Node " . shows x - -instance Show Domain where - showsPrec d (Domain x) = showParen (d > 10) $ - showString "Domain " . shows x - -instance Show Resource where - showsPrec d (Resource x) = showParen (d > 10) $ - showString "Resource " . shows x - -instance Eq Node where - (==) = equaling strNode - -instance Eq Domain where - (==) = equaling strDomain - -instance Eq Resource where - (==) = equaling strResource - -data JID = JID - { jidNode :: Maybe Node - , jidDomain :: Domain - , jidResource :: Maybe Resource - } - deriving (Eq) - -instance Show JID where - showsPrec d jid = showParen (d > 10) $ - showString "JID " . shows (formatJID jid) - -instance IsString JID where - fromString = parseJID_ . fromString - -parseJID :: Text -> Maybe JID -parseJID str = maybeJID where - (node, postNode) = case textSpanBy (/= '@') str of - (x, y) -> if Data.Text.null y - then ("", x) - else (x, Data.Text.drop 1 y) - (domain, resource) = case textSpanBy (/= '/') postNode of - (x, y) -> if Data.Text.null y - then (x, "") - else (x, Data.Text.drop 1 y) - nullable x f = if Data.Text.null x - then Just Nothing - else fmap Just (f x) - maybeJID = do - preppedNode <- nullable node (stringprepM SP.xmppNode) - preppedDomain <- stringprepM SP.nameprep domain - preppedResource <- nullable resource (stringprepM SP.xmppResource) - return $ JID - (fmap Node preppedNode) - (Domain preppedDomain) - (fmap Resource preppedResource) - stringprepM p x = case SP.stringprep p SP.defaultFlags x of - Left _ -> Nothing - Right y -> Just y - -parseJID_ :: Text -> JID -parseJID_ text = case parseJID text of - Just jid -> jid - Nothing -> error "Malformed JID" - -formatJID :: JID -> Text -formatJID (JID node (Domain domain) resource) = formatted where - formatted = Data.Text.concat [node', domain, resource'] - node' = maybe "" (\(Node x) -> Data.Text.append x "@") node - resource' = maybe "" (\(Resource x) -> Data.Text.append "/" x) resource - --- Similar to 'comparing' -equaling :: Eq a => (b -> a) -> b -> b -> Bool -equaling f x y = f x == f y - --- multi-version 'text' compatibility -textSpanBy :: (Char -> Bool) -> Text -> (Text, Text) -#if MIN_VERSION_text(0,11,0) -textSpanBy = Data.Text.span -#else -textSpanBy = Data.Text.spanBy -#endif diff --git a/Network/Protocol/XMPP/Monad.hs b/Network/Protocol/XMPP/Monad.hs deleted file mode 100644 --- a/Network/Protocol/XMPP/Monad.hs +++ /dev/null @@ -1,191 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} - --- Copyright (C) 2010-2011 John Millikin --- --- 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 --- 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 . - -module Network.Protocol.XMPP.Monad - ( XMPP (..) - , Error (..) - , Session (..) - , runXMPP - , startXMPP - , restartXMPP - - , getHandle - , getSession - - , readEvents - , getElement - , getStanza - - , putBytes - , putElement - , putStanza - ) where - -import qualified Control.Applicative as A -import qualified Control.Concurrent.MVar as M -import Control.Monad (ap) -import Control.Monad.Fix (MonadFix, mfix) -import Control.Monad.Trans (MonadIO, liftIO) -import qualified Control.Monad.Error as E -import qualified Control.Monad.Reader as R -import qualified Data.ByteString -import Data.ByteString (ByteString) -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) - -import Network.Protocol.XMPP.ErrorT -import qualified Network.Protocol.XMPP.Handle as H -import qualified Network.Protocol.XMPP.Stanza as S -import qualified Network.Protocol.XMPP.XML as X - -data Error - -- | The remote host refused the specified authentication credentials. - = AuthenticationFailure - - -- | There was an error while authenticating with the remote host. - | AuthenticationError Text - - -- | An unrecognized or malformed 'S.Stanza' was received from the remote - -- host. - | InvalidStanza X.Element - - -- | The remote host sent an invalid reply to a resource bind request. - | InvalidBindResult S.ReceivedStanza - - -- | There was an error with the underlying transport. - | TransportError Text - - -- | The remote host did not send a stream ID when accepting a component - -- connection. - | NoComponentStreamID - deriving (Show) - -data Session = Session - { sessionHandle :: H.Handle - , sessionNamespace :: Text - , sessionParser :: X.Parser - , sessionReadLock :: M.MVar () - , sessionWriteLock :: M.MVar () - } - -newtype XMPP a = XMPP { unXMPP :: ErrorT Error (R.ReaderT Session IO) a } - -instance Functor XMPP where - fmap f = XMPP . fmap f . unXMPP - -instance Monad XMPP where - return = XMPP . return - m >>= f = XMPP (unXMPP m >>= unXMPP . f) - -instance MonadIO XMPP where - liftIO = XMPP . liftIO - -instance E.MonadError XMPP where - type E.ErrorType XMPP = Error - throwError = XMPP . E.throwError - catchError m h = XMPP (E.catchError (unXMPP m) (unXMPP . h)) - -instance A.Applicative XMPP where - pure = return - (<*>) = ap - -instance MonadFix XMPP where - mfix f = XMPP (mfix (unXMPP . f)) - -runXMPP :: Session -> XMPP a -> IO (Either Error a) -runXMPP s xmpp = R.runReaderT (runErrorT (unXMPP xmpp)) s - -startXMPP :: H.Handle -> Text -> XMPP a -> IO (Either Error a) -startXMPP h ns xmpp = do - sax <- X.newParser - readLock <- M.newMVar () - writeLock <- M.newMVar () - runXMPP (Session h ns sax readLock writeLock) xmpp - -restartXMPP :: Maybe H.Handle -> XMPP a -> XMPP a -restartXMPP newH xmpp = do - Session oldH ns _ readLock writeLock <- getSession - sax <- liftIO X.newParser - let s = Session (maybe oldH id newH) ns sax readLock writeLock - XMPP (R.local (const s) (unXMPP xmpp)) - -withLock :: (Session -> M.MVar ()) -> XMPP a -> XMPP a -withLock getLock xmpp = do - s <- getSession - let mvar = getLock s - res <- liftIO (M.withMVar mvar (\_ -> runXMPP s xmpp)) - case res of - Left err -> E.throwError err - Right x -> return x - -getSession :: XMPP Session -getSession = XMPP R.ask - -getHandle :: XMPP H.Handle -getHandle = fmap sessionHandle getSession - -liftTLS :: ErrorT Text IO a -> XMPP a -liftTLS io = do - res <- liftIO (runErrorT io) - case res of - Left err -> E.throwError (TransportError err) - Right x -> return x - -putBytes :: ByteString -> XMPP () -putBytes bytes = do - h <- getHandle - liftTLS (H.hPutBytes h bytes) - -putElement :: X.Element -> XMPP () -putElement = putBytes . encodeUtf8 . X.serialiseElement - -putStanza :: S.Stanza a => a -> XMPP () -putStanza = withLock sessionWriteLock . putElement . S.stanzaToElement - -readEvents :: (Integer -> X.Event -> Bool) -> XMPP [X.Event] -readEvents done = xmpp where - xmpp = do - Session h _ p _ _ <- getSession - let nextEvents = do - -- TODO: read in larger increments - bytes <- liftTLS (H.hGetBytes h 1) - let eof = Data.ByteString.null bytes - parsed <- liftIO (X.parse p bytes eof) - case parsed of - Left err -> E.throwError (TransportError err) - Right events -> return events - X.readEvents done nextEvents - -getElement :: XMPP X.Element -getElement = xmpp where - xmpp = do - events <- readEvents endOfTree - case X.eventsToElement events of - Just x -> return x - Nothing -> E.throwError (TransportError "getElement: invalid event list") - - endOfTree 0 (X.EventEndElement _) = True - endOfTree _ _ = False - -getStanza :: XMPP S.ReceivedStanza -getStanza = withLock sessionReadLock $ do - elemt <- getElement - Session _ ns _ _ _ <- getSession - case S.elementToStanza ns elemt of - Just x -> return x - Nothing -> E.throwError (InvalidStanza elemt) diff --git a/Network/Protocol/XMPP/Stanza.hs b/Network/Protocol/XMPP/Stanza.hs deleted file mode 100644 --- a/Network/Protocol/XMPP/Stanza.hs +++ /dev/null @@ -1,276 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- Copyright (C) 2010-2011 John Millikin --- --- 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 --- 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 . - -module Network.Protocol.XMPP.Stanza - ( Stanza (..) - - , ReceivedStanza (..) - , Message (..) - , Presence (..) - , IQ (..) - , MessageType (..) - , PresenceType (..) - , IQType (..) - - , emptyMessage - , emptyPresence - , emptyIQ - - , elementToStanza - ) where - -import Control.Monad (when) -import qualified Data.Text -import Data.Text (Text) -import qualified Network.Protocol.XMPP.XML as X -import Network.Protocol.XMPP.JID (JID, parseJID, formatJID) - -class Stanza a where - stanzaTo :: a -> Maybe JID - stanzaFrom :: a -> Maybe JID - stanzaID :: a -> Maybe Text - stanzaLang :: a -> Maybe Text - stanzaPayloads :: a -> [X.Element] - stanzaToElement :: a -> X.Element - -data ReceivedStanza - = ReceivedMessage Message - | ReceivedPresence Presence - | ReceivedIQ IQ - deriving (Show) - -data Message = Message - { messageType :: MessageType - , messageTo :: Maybe JID - , messageFrom :: Maybe JID - , messageID :: Maybe Text - , messageLang :: Maybe Text - , messagePayloads :: [X.Element] - } - deriving (Show) - -instance Stanza Message where - stanzaTo = messageTo - stanzaFrom = messageFrom - stanzaID = messageID - stanzaLang = messageLang - stanzaPayloads = messagePayloads - stanzaToElement x = stanzaToElement' x "message" typeStr where - typeStr = case messageType x of - MessageNormal -> "normal" - MessageChat -> "chat" - MessageGroupChat -> "groupchat" - MessageHeadline -> "headline" - MessageError -> "error" - -data MessageType - = MessageNormal - | MessageChat - | MessageGroupChat - | MessageHeadline - | MessageError - deriving (Show, Eq) - -emptyMessage :: MessageType -> Message -emptyMessage t = Message - { messageType = t - , messageTo = Nothing - , messageFrom = Nothing - , messageID = Nothing - , messageLang = Nothing - , messagePayloads = [] - } - -data Presence = Presence - { presenceType :: PresenceType - , presenceTo :: Maybe JID - , presenceFrom :: Maybe JID - , presenceID :: Maybe Text - , presenceLang :: Maybe Text - , presencePayloads :: [X.Element] - } - deriving (Show) - -instance Stanza Presence where - stanzaTo = presenceTo - stanzaFrom = presenceFrom - stanzaID = presenceID - stanzaLang = presenceLang - stanzaPayloads = presencePayloads - stanzaToElement x = stanzaToElement' x "presence" typeStr where - typeStr = case presenceType x of - PresenceAvailable -> "" - PresenceUnavailable -> "unavailable" - PresenceSubscribe -> "subscribe" - PresenceSubscribed -> "subscribed" - PresenceUnsubscribe -> "unsubscribe" - PresenceUnsubscribed -> "unsubscribed" - PresenceProbe -> "probe" - PresenceError -> "error" - -data PresenceType - = PresenceAvailable - | PresenceUnavailable - | PresenceSubscribe - | PresenceSubscribed - | PresenceUnsubscribe - | PresenceUnsubscribed - | PresenceProbe - | PresenceError - deriving (Show, Eq) - -emptyPresence :: PresenceType -> Presence -emptyPresence t = Presence - { presenceType = t - , presenceTo = Nothing - , presenceFrom = Nothing - , presenceID = Nothing - , presenceLang = Nothing - , presencePayloads = [] - } - -data IQ = IQ - { iqType :: IQType - , iqTo :: Maybe JID - , iqFrom :: Maybe JID - , iqID :: Maybe Text - , iqLang :: Maybe Text - , iqPayload :: Maybe X.Element - } - deriving (Show) - -instance Stanza IQ where - stanzaTo = iqTo - stanzaFrom = iqFrom - stanzaID = iqID - stanzaLang = iqLang - stanzaPayloads iq = case iqPayload iq of - Just elemt -> [elemt] - Nothing -> [] - stanzaToElement x = stanzaToElement' x "iq" typeStr where - typeStr = case iqType x of - IQGet -> "get" - IQSet -> "set" - IQResult -> "result" - IQError -> "error" - -data IQType - = IQGet - | IQSet - | IQResult - | IQError - deriving (Show, Eq) - -emptyIQ :: IQType -> IQ -emptyIQ t = IQ - { iqType = t - , iqTo = Nothing - , iqFrom = Nothing - , iqID = Nothing - , iqLang = Nothing - , iqPayload = Nothing - } - -stanzaToElement' :: Stanza a => a -> X.Name -> Text -> X.Element -stanzaToElement' stanza name typeStr = X.element name attrs payloads where - payloads = map X.NodeElement (stanzaPayloads stanza) - attrs = concat - [ mattr "to" (fmap formatJID . stanzaTo) - , mattr "from" (fmap formatJID . stanzaFrom) - , mattr "id" stanzaID - , mattr "xml:lang" stanzaLang - , if Data.Text.null typeStr then [] else [("type", typeStr)] - ] - mattr label f = case f stanza of - Nothing -> [] - Just text -> [(label, text)] - -elementToStanza :: Text -> X.Element -> Maybe ReceivedStanza -elementToStanza ns elemt = do - let elemNS = X.nameNamespace (X.elementName elemt) - when (elemNS /= Just ns) Nothing - - let elemName = X.nameLocalName (X.elementName elemt) - case elemName of - "message" -> ReceivedMessage `fmap` parseMessage elemt - "presence" -> ReceivedPresence `fmap` parsePresence elemt - "iq" -> ReceivedIQ `fmap` parseIQ elemt - _ -> Nothing - -parseMessage :: X.Element -> Maybe Message -parseMessage elemt = do - typeStr <- X.attributeText "type" elemt - msgType <- case typeStr of - "normal" -> Just MessageNormal - "chat" -> Just MessageChat - "groupchat" -> Just MessageGroupChat - "headline" -> Just MessageHeadline - "error" -> Just MessageError - _ -> Nothing - msgTo <- xmlJID "to" elemt - msgFrom <- xmlJID "from" elemt - let msgID = X.attributeText "id" elemt - let msgLang = X.attributeText "lang" elemt - let payloads = X.elementChildren elemt - return (Message msgType msgTo msgFrom msgID msgLang payloads) - -parsePresence :: X.Element -> Maybe Presence -parsePresence elemt = do - let typeStr = maybe "" id (X.attributeText "type" elemt) - pType <- case typeStr of - "" -> Just PresenceAvailable - "unavailable" -> Just PresenceUnavailable - "subscribe" -> Just PresenceSubscribe - "subscribed" -> Just PresenceSubscribed - "unsubscribe" -> Just PresenceUnsubscribe - "unsubscribed" -> Just PresenceUnsubscribed - "probe" -> Just PresenceProbe - "error" -> Just PresenceError - _ -> Nothing - - msgTo <- xmlJID "to" elemt - msgFrom <- xmlJID "from" elemt - let msgID = X.attributeText "id" elemt - let msgLang = X.attributeText "lang" elemt - let payloads = X.elementChildren elemt - return (Presence pType msgTo msgFrom msgID msgLang payloads) - -parseIQ :: X.Element -> Maybe IQ -parseIQ elemt = do - typeStr <- X.attributeText "type" elemt - iqType <- case typeStr of - "get" -> Just IQGet - "set" -> Just IQSet - "result" -> Just IQResult - "error" -> Just IQError - _ -> Nothing - - msgTo <- xmlJID "to" elemt - msgFrom <- xmlJID "from" elemt - let msgID = X.attributeText "id" elemt - let msgLang = X.attributeText "lang" elemt - let payload = case X.elementChildren elemt of - [] -> Nothing - child:_ -> Just child - return (IQ iqType msgTo msgFrom msgID msgLang payload) - -xmlJID :: X.Name -> X.Element -> Maybe (Maybe JID) -xmlJID name elemt = case X.attributeText name elemt of - Nothing -> Just Nothing - Just raw -> case parseJID raw of - Just jid -> Just (Just jid) - Nothing -> Nothing diff --git a/Network/Protocol/XMPP/XML.hs b/Network/Protocol/XMPP/XML.hs deleted file mode 100644 --- a/Network/Protocol/XMPP/XML.hs +++ /dev/null @@ -1,186 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- Copyright (C) 2010-2011 John Millikin --- --- 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 --- 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 . - -module Network.Protocol.XMPP.XML - ( module Data.XML.Types - - -- * Constructors - , element - - -- * Misc - , contentText - , escape - , serialiseElement - , readEvents - - -- * libxml-sax-0.4 API imitation - , Parser - , newParser - , parse - , eventsToElement - - ) where - -import Control.Monad (when) -import Data.ByteString (ByteString) -import qualified Data.Text -import Data.Text (Text) -import Data.XML.Types -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import qualified Text.XML.LibXML.SAX as SAX - -contentText :: Content -> Text -contentText (ContentText t) = t -contentText (ContentEntity e) = Data.Text.concat ["&", e, ";"] - -escape :: Text -> Text -escape = Data.Text.concatMap escapeChar where - escapeChar c = case c of - '&' -> "&" - '<' -> "<" - '>' -> ">" - '"' -> """ - '\'' -> "'" - _ -> Data.Text.singleton c - -escapeContent :: Content -> Text -escapeContent (ContentText t) = escape t -escapeContent (ContentEntity e) = Data.Text.concat ["&", escape e, ";"] - -element :: Name -> [(Name, Text)] -> [Node] -> Element -element name attrs children = Element name attrs' children where - attrs' = map (uncurry mkattr) attrs - -mkattr :: Name -> Text -> (Name, [Content]) -mkattr n val = (n, [ContentText val]) - --- A somewhat primitive serialisation function --- --- TODO: better namespace / prefix handling -serialiseElement :: Element -> Text -serialiseElement e = text where - text = Data.Text.concat ["<", eName, " ", attrs, ">", contents, ""] - eName = formatName (elementName e) - formatName = escape . nameLocalName - attrs = Data.Text.intercalate " " (map attr (elementAttributes e ++ nsattr)) - attr (n, c) = Data.Text.concat ([formatName n, "=\""] ++ map escapeContent c ++ ["\""]) - nsattr = case nameNamespace $ elementName e of - Nothing -> [] - Just ns -> [mkattr "xmlns" ns] - contents = Data.Text.concat (map serialiseNode (elementNodes e)) - - serialiseNode (NodeElement e') = serialiseElement e' - serialiseNode (NodeContent c) = escape (contentText c) - serialiseNode (NodeComment _) = "" - serialiseNode (NodeInstruction _) = "" - --- quick-and-dirty imitation of libxml-sax-0.4 API; later, this should --- probably be rewritten to use ST and discard the list parsing -data Parser = Parser (SAX.Parser IO) (IORef (Either Text [Event])) - -newParser :: IO Parser -newParser = do - ref <- newIORef (Right []) - p <- SAX.newParserIO Nothing - - let addEvent e = do - x <- readIORef ref - case x of - Left _ -> return () - Right es -> writeIORef ref (Right (e:es)) - return True - - SAX.setCallback p SAX.parsedBeginElement (\name attrs -> addEvent (EventBeginElement name attrs)) - SAX.setCallback p SAX.parsedEndElement (addEvent . EventEndElement) - SAX.setCallback p SAX.parsedCharacters (addEvent . EventContent . ContentText) - SAX.setCallback p SAX.parsedComment (addEvent . EventComment) - SAX.setCallback p SAX.parsedInstruction (addEvent . EventInstruction) - SAX.setCallback p SAX.reportError (\err -> writeIORef ref (Left err) >> return False) - - return (Parser p ref) - -parse :: Parser -> ByteString -> Bool -> IO (Either Text [Event]) -parse (Parser p ref) bytes finish = do - writeIORef ref (Right []) - SAX.parseBytes p bytes - when finish (SAX.parseComplete p) - eitherEvents <- readIORef ref - return $ case eitherEvents of - Left err -> Left err - Right events -> Right (reverse events) - -readEvents :: Monad m - => (Integer -> Event -> Bool) - -> m [Event] - -> m [Event] -readEvents done nextEvents = readEvents' 0 [] where - readEvents' depth acc = do - events <- nextEvents - let (done', depth', acc') = step events depth acc - if done' - then return acc' - else readEvents' depth' acc' - - step [] depth acc = (False, depth, acc) - step (e:es) depth acc = let - depth' = depth + case e of - (EventBeginElement _ _) -> 1 - (EventEndElement _) -> (- 1) - _ -> 0 - acc' = e : acc - in if done depth' e - then (True, depth', reverse acc') - else step es depth' acc' - --- | Convert a list of events to a single 'Element'. If the events do not --- contain at least one valid element, 'Nothing' will be returned instead. -eventsToElement :: [Event] -> Maybe Element -eventsToElement es = case eventsToNodes es >>= isElement of - (e:_) -> Just e - _ -> Nothing - -eventsToNodes :: [Event] -> [Node] -eventsToNodes = concatMap blockToNodes . splitBlocks - --- Split event list into a sequence of "blocks", which are the events including --- and between a pair of tags. and are both --- single blocks. -splitBlocks :: [Event] -> [[Event]] -splitBlocks es = ret where - (_, _, ret) = foldl splitBlocks' (0, [], []) es - - splitBlocks' (depth, accum, allAccum) e = split where - split = if depth' == 0 - then (depth', [], allAccum ++ [accum']) - else (depth', accum', allAccum) - accum' = accum ++ [e] - depth' :: Integer - depth' = depth + case e of - (EventBeginElement _ _) -> 1 - (EventEndElement _) -> (- 1) - _ -> 0 - -blockToNodes :: [Event] -> [Node] -blockToNodes [] = [] -blockToNodes (begin:rest) = nodes where - end = last rest - nodes = case (begin, end) of - (EventBeginElement name attrs, EventEndElement _) -> [node name attrs] - (EventContent c, _) -> [NodeContent c] - _ -> [] - - node n as = NodeElement (Element n as (eventsToNodes (init rest))) diff --git a/lib/Network/Protocol/XMPP.hs b/lib/Network/Protocol/XMPP.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Protocol/XMPP.hs @@ -0,0 +1,73 @@ +-- Copyright (C) 2010-2011 John Millikin +-- +-- 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 +-- 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 . + +module Network.Protocol.XMPP + ( + -- * JIDs + JID (..) + , Node + , Domain + , Resource + + , strNode + , strDomain + , strResource + + , parseJID + , formatJID + + -- * Stanzas + , Stanza + ( stanzaTo + , stanzaFrom + , stanzaID + , stanzaLang + , stanzaPayloads + ) + + , ReceivedStanza (..) + , Message (..) + , Presence (..) + , IQ (..) + , MessageType (..) + , PresenceType (..) + , IQType (..) + + , emptyMessage + , emptyPresence + , emptyIQ + + -- * The XMPP monad + , XMPP + , Server (..) + , Error (..) + , runClient + , runComponent + , putStanza + , getStanza + , bindJID + + -- ** Resuming sessions + , Session + , getSession + , runXMPP + ) where + +import Network.Protocol.XMPP.Client +import Network.Protocol.XMPP.Component +import Network.Protocol.XMPP.Connections +import Network.Protocol.XMPP.JID +import Network.Protocol.XMPP.Monad +import Network.Protocol.XMPP.Stanza diff --git a/lib/Network/Protocol/XMPP/Client.hs b/lib/Network/Protocol/XMPP/Client.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Protocol/XMPP/Client.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- Copyright (C) 2010-2011 John Millikin +-- +-- 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 +-- 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 . + +module Network.Protocol.XMPP.Client + ( runClient + , bindJID + ) where + +import Control.Monad ((>=>)) +import Control.Monad.Error (throwError) +import Control.Monad.Trans (liftIO) +import Data.ByteString (ByteString) +import Data.Text (Text) +import Network (connectTo) +import qualified System.IO as IO + +import qualified Network.Protocol.XMPP.Client.Authentication as A +import qualified Network.Protocol.XMPP.Connections as C +import qualified Network.Protocol.XMPP.Client.Features as F +import qualified Network.Protocol.XMPP.Handle as H +import qualified Network.Protocol.XMPP.JID as J +import qualified Network.Protocol.XMPP.Monad as M +import qualified Network.Protocol.XMPP.XML as X +import Network.Protocol.XMPP.ErrorT +import Network.Protocol.XMPP.Stanza + +runClient :: C.Server + -> J.JID -- ^ Client JID + -> Text -- ^ Username + -> Text -- ^ Password + -> M.XMPP a + -> IO (Either M.Error a) +runClient server jid username password xmpp = do + -- Open a TCP connection + let C.Server sjid host port = server + rawHandle <- connectTo host port + IO.hSetBuffering rawHandle IO.NoBuffering + let handle = H.PlainHandle rawHandle + + -- Open the initial stream and authenticate + M.startXMPP handle "jabber:client" $ do + features <- newStream sjid + tryTLS sjid features $ \tlsFeatures -> do + let mechanisms = authenticationMechanisms tlsFeatures + A.authenticate mechanisms jid sjid username password + M.restartXMPP Nothing (newStream sjid >> xmpp) + +newStream :: J.JID -> M.XMPP [F.Feature] +newStream jid = do + M.putBytes (C.xmlHeader "jabber:client" jid) + void (M.readEvents C.startOfStream) + F.parseFeatures `fmap` M.getElement + +tryTLS :: J.JID -> [F.Feature] -> ([F.Feature] -> M.XMPP a) -> M.XMPP a +tryTLS sjid features m + | not (streamSupportsTLS features) = m features + | otherwise = do + M.putElement xmlStartTLS + void M.getElement + h <- M.getHandle + eitherTLS <- liftIO (runErrorT (H.startTLS h)) + case eitherTLS of + Left err -> throwError (M.TransportError err) + Right tls -> M.restartXMPP (Just tls) (newStream sjid >>= m) + +authenticationMechanisms :: [F.Feature] -> [ByteString] +authenticationMechanisms = step where + step [] = [] + step (f:fs) = case f of + (F.FeatureSASL ms) -> ms + _ -> step fs + +-- | Send a @\@ message for the given 'J.JID', returning the server's reply. In +-- most cases the reply will be the same as the input. However, if the input has no +-- 'J.Resource', the returned 'J.JID' will contain a generated 'J.Resource'. +-- +-- Clients must bind a 'J.JID' before sending any 'Stanza's. +bindJID :: J.JID -> M.XMPP J.JID +bindJID jid = do + -- Bind + M.putStanza (bindStanza (J.jidResource jid)) + bindResult <- M.getStanza + let getJID = + X.elementChildren + >=> X.isNamed "{urn:ietf:params:xml:ns:xmpp-bind}jid" + >=> X.elementNodes + >=> X.isContent + >=> return . X.contentText + + let maybeJID = do + iq <- case bindResult of + ReceivedIQ x -> Just x + _ -> Nothing + payload <- iqPayload iq + + case getJID payload of + [] -> Nothing + (str:_) -> J.parseJID str + + returnedJID <- case maybeJID of + Just x -> return x + Nothing -> throwError (M.InvalidBindResult bindResult) + + -- Session + M.putStanza sessionStanza + void M.getStanza + + M.putStanza (emptyPresence PresenceAvailable) + void M.getStanza + + return returnedJID + +bindStanza :: Maybe J.Resource -> IQ +bindStanza resource = (emptyIQ IQSet) { iqPayload = Just payload } where + payload = X.element "{urn:ietf:params:xml:ns:xmpp-bind}bind" [] requested + requested = case fmap J.strResource resource of + Nothing -> [] + Just x -> [X.NodeElement (X.element "resource" [] [X.NodeContent (X.ContentText x)])] + +sessionStanza :: IQ +sessionStanza = (emptyIQ IQSet) { iqPayload = Just payload } where + payload = X.element "{urn:ietf:params:xml:ns:xmpp-session}session" [] [] + +streamSupportsTLS :: [F.Feature] -> Bool +streamSupportsTLS = any isStartTLS where + isStartTLS (F.FeatureStartTLS _) = True + isStartTLS _ = False + +xmlStartTLS :: X.Element +xmlStartTLS = X.element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] [] + +void :: Monad m => m a -> m () +void m = m >> return () diff --git a/lib/Network/Protocol/XMPP/Client/Authentication.hs b/lib/Network/Protocol/XMPP/Client/Authentication.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Protocol/XMPP/Client/Authentication.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- Copyright (C) 2009-2011 John Millikin +-- +-- 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 +-- 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 . + +module Network.Protocol.XMPP.Client.Authentication + ( Result (..) + , authenticate + ) where + +import qualified Control.Exception as Exc +import Control.Monad (when, (>=>)) +import Control.Monad.IO.Class (MonadIO, liftIO) +import qualified Control.Monad.Error as E +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 +import qualified Data.Text +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Data.Typeable (Typeable) +import qualified Network.Protocol.SASL.GNU as SASL + +import qualified Network.Protocol.XMPP.Monad as M +import qualified Network.Protocol.XMPP.XML as X +import Network.Protocol.XMPP.JID (JID, formatJID, jidResource) + +data Result = Success | Failure + deriving (Show, Eq) + +data AuthException = XmppError M.Error | SaslError Text + deriving (Typeable, Show) + +instance Exc.Exception AuthException + +authenticate :: [ByteString] -- ^ Mechanisms + -> JID -- ^ User JID + -> JID -- ^ Server JID + -> Text -- ^ Username + -> Text -- ^ Password + -> M.XMPP () +authenticate xmppMechanisms userJID serverJID username password = xmpp where + mechanisms = map SASL.Mechanism xmppMechanisms + authz = formatJID (userJID { jidResource = Nothing }) + hostname = formatJID serverJID + + xmpp = do + ctx <- M.getSession + res <- liftIO . Exc.try . SASL.runSASL $ do + suggested <- SASL.clientSuggestMechanism mechanisms + case suggested of + Nothing -> saslError "No supported authentication mechanism" + Just mechanism -> authSasl ctx mechanism + case res of + Right Success -> return () + Right Failure -> E.throwError M.AuthenticationFailure + Left (XmppError err) -> E.throwError err + Left (SaslError err) -> E.throwError (M.AuthenticationError err) + + authSasl ctx mechanism = do + let (SASL.Mechanism mechBytes) = mechanism + sessionResult <- SASL.runClient mechanism $ do + SASL.setProperty SASL.PropertyAuthzID (encodeUtf8 authz) + SASL.setProperty SASL.PropertyAuthID (encodeUtf8 username) + SASL.setProperty SASL.PropertyPassword (encodeUtf8 password) + SASL.setProperty SASL.PropertyService "xmpp" + SASL.setProperty SASL.PropertyHostname (encodeUtf8 hostname) + + (b64text, rc) <- SASL.step64 "" + putElement ctx $ X.element "{urn:ietf:params:xml:ns:xmpp-sasl}auth" + [("mechanism", Data.Text.pack (Data.ByteString.Char8.unpack mechBytes))] + [X.NodeContent (X.ContentText (Data.Text.pack (Data.ByteString.Char8.unpack b64text)))] + + case rc of + SASL.Complete -> saslFinish ctx + SASL.NeedsMore -> saslLoop ctx + + case sessionResult of + Right x -> return x + Left err -> saslError (Data.Text.pack (show err)) + +saslLoop :: M.Session -> SASL.Session Result +saslLoop ctx = do + elemt <- getElement ctx + let name = "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" + let getChallengeText = + X.isNamed name + >=> X.elementNodes + >=> X.isContent + >=> return . X.contentText + let challengeText = getChallengeText elemt + when (null challengeText) (saslError "Received empty challenge") + + (b64text, rc) <- SASL.step64 (Data.ByteString.Char8.pack (concatMap Data.Text.unpack challengeText)) + putElement ctx $ X.element "{urn:ietf:params:xml:ns:xmpp-sasl}response" + [] [X.NodeContent (X.ContentText (Data.Text.pack (Data.ByteString.Char8.unpack b64text)))] + case rc of + SASL.Complete -> saslFinish ctx + SASL.NeedsMore -> saslLoop ctx + +saslFinish :: M.Session -> SASL.Session Result +saslFinish ctx = do + elemt <- getElement ctx + let name = "{urn:ietf:params:xml:ns:xmpp-sasl}success" + let success = X.isNamed name elemt + return (if null success then Failure else Success) + +putElement :: M.Session -> X.Element -> SASL.Session () +putElement ctx elemt = liftIO $ do + res <- M.runXMPP ctx (M.putElement elemt) + case res of + Left err -> Exc.throwIO (XmppError err) + Right x -> return x + +getElement :: M.Session -> SASL.Session X.Element +getElement ctx = liftIO $ do + res <- M.runXMPP ctx M.getElement + case res of + Left err -> Exc.throwIO (XmppError err) + Right x -> return x + +saslError :: MonadIO m => Text -> m a +saslError = liftIO . Exc.throwIO . SaslError diff --git a/lib/Network/Protocol/XMPP/Client/Features.hs b/lib/Network/Protocol/XMPP/Client/Features.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Protocol/XMPP/Client/Features.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- Copyright (C) 2010-2011 John Millikin +-- +-- 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 +-- 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 . + +module Network.Protocol.XMPP.Client.Features + ( Feature (..) + , parseFeatures + , parseFeature + ) where + +import Control.Arrow ((&&&)) +import qualified Data.ByteString.Char8 +import Data.ByteString (ByteString) +import qualified Data.Text +import qualified Network.Protocol.XMPP.XML as X + +data Feature = + FeatureStartTLS Bool + | FeatureSASL [ByteString] + | FeatureRegister + | FeatureBind + | FeatureSession + | FeatureUnknown X.Element + deriving (Show, Eq) + +parseFeatures :: X.Element -> [Feature] +parseFeatures e = + X.isNamed nameFeatures e + >>= X.elementChildren + >>= return . parseFeature + +parseFeature :: X.Element -> Feature +parseFeature elemt = feature where + unpackName = (maybe "" id . X.nameNamespace) &&& X.nameLocalName + feature = case unpackName (X.elementName elemt) of + ("urn:ietf:params:xml:ns:xmpp-tls", "starttls") -> parseFeatureTLS elemt + ("urn:ietf:params:xml:ns:xmpp-sasl", "mechanisms") -> parseFeatureSASL elemt + ("http://jabber.org/features/iq-register", "register") -> FeatureRegister + ("urn:ietf:params:xml:ns:xmpp-bind", "bind") -> FeatureBind + ("urn:ietf:params:xml:ns:xmpp-session", "session") -> FeatureSession + _ -> FeatureUnknown elemt + +parseFeatureTLS :: X.Element -> Feature +parseFeatureTLS _ = FeatureStartTLS True -- TODO: detect whether or not required + +parseFeatureSASL :: X.Element -> Feature +parseFeatureSASL e = FeatureSASL $ + X.elementChildren e + >>= X.isNamed nameMechanism + >>= X.elementNodes + >>= X.isContent + >>= return . Data.ByteString.Char8.pack . Data.Text.unpack . X.contentText + +nameMechanism :: X.Name +nameMechanism = "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" + +nameFeatures :: X.Name +nameFeatures = "{http://etherx.jabber.org/streams}features" diff --git a/lib/Network/Protocol/XMPP/Component.hs b/lib/Network/Protocol/XMPP/Component.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Protocol/XMPP/Component.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- Copyright (C) 2010 Stephan Maka +-- Copyright (C) 2010-2011 John Millikin +-- +-- 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 +-- 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 . + +module Network.Protocol.XMPP.Component + ( runComponent + ) where + +import Control.Monad (when) +import Control.Monad.Error (throwError) +import Data.Bits (shiftR, (.&.)) +import Data.Char (intToDigit) +import qualified Data.ByteString +import Data.ByteString (ByteString) +import qualified Data.Text +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Network (connectTo) +import Network.Protocol.SASL.GNU (sha1) +import qualified System.IO as IO + +import qualified Network.Protocol.XMPP.Connections as C +import qualified Network.Protocol.XMPP.Handle as H +import qualified Network.Protocol.XMPP.Monad as M +import qualified Network.Protocol.XMPP.XML as X +import Network.Protocol.XMPP.JID (JID) + +runComponent :: C.Server + -> Text -- ^ Server secret + -> M.XMPP a + -> IO (Either M.Error a) +runComponent server password xmpp = do + let C.Server jid host port = server + rawHandle <- connectTo host port + IO.hSetBuffering rawHandle IO.NoBuffering + let handle = H.PlainHandle rawHandle + M.startXMPP handle "jabber:component:accept" $ do + streamID <- beginStream jid + authenticate streamID password + xmpp + +beginStream :: JID -> M.XMPP Text +beginStream jid = do + M.putBytes $ C.xmlHeader "jabber:component:accept" jid + events <- M.readEvents C.startOfStream + case parseStreamID $ last events of + Nothing -> throwError M.NoComponentStreamID + Just x -> return x + +parseStreamID :: X.Event -> Maybe Text +parseStreamID (X.EventBeginElement name attrs) = X.attributeText + "{jabber:component:accept}jid" + (X.Element name attrs []) +parseStreamID _ = Nothing + +authenticate :: Text -> Text -> M.XMPP () +authenticate streamID password = do + let bytes = buildSecret streamID password + let digest = showDigest (sha1 bytes) + M.putElement (X.element "handshake" [] [X.NodeContent (X.ContentText digest)]) + result <- M.getElement + let nameHandshake = "{jabber:component:accept}handshake" + when (null (X.isNamed nameHandshake result)) (throwError M.AuthenticationFailure) + +buildSecret :: Text -> Text -> ByteString +buildSecret sid password = encodeUtf8 (X.escape (Data.Text.append sid password)) + +showDigest :: ByteString -> Text +showDigest = Data.Text.pack . concatMap wordToHex . Data.ByteString.unpack where + wordToHex x = [hexDig (shiftR x 4), hexDig (x .&. 0xF)] + hexDig = intToDigit . fromIntegral diff --git a/lib/Network/Protocol/XMPP/Connections.hs b/lib/Network/Protocol/XMPP/Connections.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Protocol/XMPP/Connections.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- Copyright (C) 2010-2011 John Millikin +-- +-- 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 +-- 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 . + +module Network.Protocol.XMPP.Connections + ( Server (..) + , xmlHeader + , startOfStream + , qnameStream + ) where + +import Network (HostName, PortID) +import Data.ByteString (ByteString) +import qualified Data.Text +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) + +import qualified Network.Protocol.XMPP.XML as X +import Network.Protocol.XMPP.JID (JID, formatJID) + +data Server = Server + { serverJID :: JID + , serverHostname :: HostName + , serverPort :: PortID + } + +-- Since only the opening tag should be written, normal XML +-- serialization cannot be used. Be careful to escape any embedded +-- attributes. +xmlHeader :: Text -> JID -> ByteString +xmlHeader ns jid = encodeUtf8 header where + attr x = Data.Text.concat ["\"", X.escape x, "\""] + header = Data.Text.concat + [ "\n" + , "" + ] + +startOfStream :: Integer -> X.Event -> Bool +startOfStream depth event = case (depth, event) of + (1, (X.EventBeginElement elemName _)) -> qnameStream == elemName + _ -> False + +qnameStream :: X.Name +qnameStream = "{http://etherx.jabber.org/streams}stream" diff --git a/lib/Network/Protocol/XMPP/ErrorT.hs b/lib/Network/Protocol/XMPP/ErrorT.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Protocol/XMPP/ErrorT.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE TypeFamilies #-} + +-- Copyright (C) 2010-2011 John Millikin +-- +-- 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 +-- 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 . + +module Network.Protocol.XMPP.ErrorT + ( ErrorT (..) + , mapErrorT + ) where + +import Control.Monad (liftM) +import Control.Monad.Fix (MonadFix, mfix) +import Control.Monad.Trans (MonadIO, liftIO) +import Control.Monad.Trans.Class (MonadTrans, lift) +import qualified Control.Monad.Error as E +import Control.Monad.Error (ErrorType) +import qualified Control.Monad.Reader as R +import Control.Monad.Reader (EnvType) + +-- A custom version of ErrorT, without the 'Error' class restriction. + +newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) } + +instance Functor m => Functor (ErrorT e m) where + fmap f = ErrorT . fmap (fmap f) . runErrorT + +instance Monad m => Monad (ErrorT e m) where + return = ErrorT . return . Right + (>>=) m k = ErrorT $ do + x <- runErrorT m + case x of + Left l -> return (Left l) + Right r -> runErrorT (k r) + +instance Monad m => E.MonadError (ErrorT e m) where + type ErrorType (ErrorT e m) = e + throwError = ErrorT . return . Left + catchError m h = ErrorT $ do + x <- runErrorT m + case x of + Left l -> runErrorT (h l) + Right r -> return (Right r) + +instance MonadTrans (ErrorT e) where + lift = ErrorT . liftM Right + +instance R.MonadReader m => R.MonadReader (ErrorT e m) where + type EnvType (ErrorT e m) = EnvType m + ask = lift R.ask + local = mapErrorT . R.local + +instance MonadIO m => MonadIO (ErrorT e m) where + liftIO = lift . liftIO + +instance MonadFix m => MonadFix (ErrorT e m) where + mfix f = ErrorT $ mfix $ \ex -> runErrorT $ f $ case ex of + Right x -> x + _ -> error "empty mfix parameter" + +mapErrorT :: (m (Either e a) -> n (Either e' b)) + -> ErrorT e m a + -> ErrorT e' n b +mapErrorT f m = ErrorT (f (runErrorT m)) diff --git a/lib/Network/Protocol/XMPP/Handle.hs b/lib/Network/Protocol/XMPP/Handle.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Protocol/XMPP/Handle.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- Copyright (C) 2010-2011 John Millikin +-- +-- 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 +-- 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 . + +module Network.Protocol.XMPP.Handle + ( Handle (..) + , startTLS + , hPutBytes + , hGetBytes + ) where + +import Control.Monad (when) +import qualified Control.Monad.Error as E +import Control.Monad.Trans (liftIO) +import qualified Data.ByteString +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy +import qualified Data.Text +import Data.Text (Text) +import qualified System.IO as IO +import qualified Network.Protocol.TLS.GNU as TLS +import Network.Protocol.XMPP.ErrorT + +data Handle = + PlainHandle IO.Handle + | SecureHandle IO.Handle TLS.Session + +liftTLS :: TLS.Session -> TLS.TLS a -> ErrorT Text IO a +liftTLS s = liftTLS' . TLS.runTLS s + +liftTLS' :: IO (Either TLS.Error a) -> ErrorT Text IO a +liftTLS' io = do + eitherX <- liftIO io + case eitherX of + Left err -> E.throwError (Data.Text.pack (show err)) + Right x -> return x + +startTLS :: Handle -> ErrorT Text IO Handle +startTLS (SecureHandle _ _) = E.throwError "Can't start TLS on a secure handle" +startTLS (PlainHandle h) = liftTLS' $ TLS.runClient (TLS.handleTransport h) $ do + TLS.setPriority [TLS.X509] + TLS.setCredentials =<< TLS.certificateCredentials + TLS.handshake + SecureHandle h `fmap` TLS.getSession + +hPutBytes :: Handle -> ByteString -> ErrorT Text IO () +hPutBytes (PlainHandle h) = liftIO . Data.ByteString.hPut h +hPutBytes (SecureHandle _ s) = liftTLS s . TLS.putBytes . toLazy where + toLazy bytes = Data.ByteString.Lazy.fromChunks [bytes] + +hGetBytes :: Handle -> Integer -> ErrorT Text IO ByteString +hGetBytes (PlainHandle h) n = liftIO (Data.ByteString.hGet h (fromInteger n)) +hGetBytes (SecureHandle h s) n = liftTLS s $ do + pending <- TLS.checkPending + let wait = IO.hWaitForInput h (- 1) >> return () + when (pending == 0) (liftIO wait) + lazy <- TLS.getBytes n + return (Data.ByteString.concat (Data.ByteString.Lazy.toChunks lazy)) diff --git a/lib/Network/Protocol/XMPP/JID.hs b/lib/Network/Protocol/XMPP/JID.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Protocol/XMPP/JID.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} + +-- Copyright (C) 2010-2011 John Millikin +-- +-- 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 +-- 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 . + +module Network.Protocol.XMPP.JID + ( JID (..) + , Node (..) + , Domain (..) + , Resource (..) + + , parseJID + , parseJID_ + , formatJID + ) where + +import qualified Data.Text +import Data.Text (Text) +import qualified Data.Text.IDN.StringPrep as SP +import Data.String (IsString, fromString) + +newtype Node = Node { strNode :: Text } +newtype Domain = Domain { strDomain :: Text } +newtype Resource = Resource { strResource :: Text } + +instance Show Node where + showsPrec d (Node x) = showParen (d > 10) $ + showString "Node " . shows x + +instance Show Domain where + showsPrec d (Domain x) = showParen (d > 10) $ + showString "Domain " . shows x + +instance Show Resource where + showsPrec d (Resource x) = showParen (d > 10) $ + showString "Resource " . shows x + +instance Eq Node where + (==) = equaling strNode + +instance Eq Domain where + (==) = equaling strDomain + +instance Eq Resource where + (==) = equaling strResource + +data JID = JID + { jidNode :: Maybe Node + , jidDomain :: Domain + , jidResource :: Maybe Resource + } + deriving (Eq) + +instance Show JID where + showsPrec d jid = showParen (d > 10) $ + showString "JID " . shows (formatJID jid) + +instance IsString JID where + fromString = parseJID_ . fromString + +parseJID :: Text -> Maybe JID +parseJID str = maybeJID where + (node, postNode) = case textSpanBy (/= '@') str of + (x, y) -> if Data.Text.null y + then ("", x) + else (x, Data.Text.drop 1 y) + (domain, resource) = case textSpanBy (/= '/') postNode of + (x, y) -> if Data.Text.null y + then (x, "") + else (x, Data.Text.drop 1 y) + nullable x f = if Data.Text.null x + then Just Nothing + else fmap Just (f x) + maybeJID = do + preppedNode <- nullable node (stringprepM SP.xmppNode) + preppedDomain <- stringprepM SP.nameprep domain + preppedResource <- nullable resource (stringprepM SP.xmppResource) + return $ JID + (fmap Node preppedNode) + (Domain preppedDomain) + (fmap Resource preppedResource) + stringprepM p x = case SP.stringprep p SP.defaultFlags x of + Left _ -> Nothing + Right y -> Just y + +parseJID_ :: Text -> JID +parseJID_ text = case parseJID text of + Just jid -> jid + Nothing -> error "Malformed JID" + +formatJID :: JID -> Text +formatJID (JID node (Domain domain) resource) = formatted where + formatted = Data.Text.concat [node', domain, resource'] + node' = maybe "" (\(Node x) -> Data.Text.append x "@") node + resource' = maybe "" (\(Resource x) -> Data.Text.append "/" x) resource + +-- Similar to 'comparing' +equaling :: Eq a => (b -> a) -> b -> b -> Bool +equaling f x y = f x == f y + +-- multi-version 'text' compatibility +textSpanBy :: (Char -> Bool) -> Text -> (Text, Text) +#if MIN_VERSION_text(0,11,0) +textSpanBy = Data.Text.span +#else +textSpanBy = Data.Text.spanBy +#endif diff --git a/lib/Network/Protocol/XMPP/Monad.hs b/lib/Network/Protocol/XMPP/Monad.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Protocol/XMPP/Monad.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} + +-- Copyright (C) 2010-2011 John Millikin +-- +-- 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 +-- 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 . + +module Network.Protocol.XMPP.Monad + ( XMPP (..) + , Error (..) + , Session (..) + , runXMPP + , startXMPP + , restartXMPP + + , getHandle + , getSession + + , readEvents + , getElement + , getStanza + + , putBytes + , putElement + , putStanza + ) where + +import qualified Control.Applicative as A +import qualified Control.Concurrent.MVar as M +import Control.Monad (ap) +import Control.Monad.Fix (MonadFix, mfix) +import Control.Monad.Trans (MonadIO, liftIO) +import qualified Control.Monad.Error as E +import Control.Monad.Error (ErrorType) +import qualified Control.Monad.Reader as R +import qualified Data.ByteString +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) + +import Network.Protocol.XMPP.ErrorT +import qualified Network.Protocol.XMPP.Handle as H +import qualified Network.Protocol.XMPP.Stanza as S +import qualified Network.Protocol.XMPP.XML as X + +data Error + -- | The remote host refused the specified authentication credentials. + = AuthenticationFailure + + -- | There was an error while authenticating with the remote host. + | AuthenticationError Text + + -- | An unrecognized or malformed 'S.Stanza' was received from the remote + -- host. + | InvalidStanza X.Element + + -- | The remote host sent an invalid reply to a resource bind request. + | InvalidBindResult S.ReceivedStanza + + -- | There was an error with the underlying transport. + | TransportError Text + + -- | The remote host did not send a stream ID when accepting a component + -- connection. + | NoComponentStreamID + deriving (Show) + +data Session = Session + { sessionHandle :: H.Handle + , sessionNamespace :: Text + , sessionParser :: X.Parser + , sessionReadLock :: M.MVar () + , sessionWriteLock :: M.MVar () + } + +newtype XMPP a = XMPP { unXMPP :: ErrorT Error (R.ReaderT Session IO) a } + +instance Functor XMPP where + fmap f = XMPP . fmap f . unXMPP + +instance Monad XMPP where + return = XMPP . return + m >>= f = XMPP (unXMPP m >>= unXMPP . f) + +instance MonadIO XMPP where + liftIO = XMPP . liftIO + +instance E.MonadError XMPP where + type ErrorType XMPP = Error + throwError = XMPP . E.throwError + catchError m h = XMPP (E.catchError (unXMPP m) (unXMPP . h)) + +instance A.Applicative XMPP where + pure = return + (<*>) = ap + +instance MonadFix XMPP where + mfix f = XMPP (mfix (unXMPP . f)) + +runXMPP :: Session -> XMPP a -> IO (Either Error a) +runXMPP s xmpp = R.runReaderT (runErrorT (unXMPP xmpp)) s + +startXMPP :: H.Handle -> Text -> XMPP a -> IO (Either Error a) +startXMPP h ns xmpp = do + sax <- X.newParser + readLock <- M.newMVar () + writeLock <- M.newMVar () + runXMPP (Session h ns sax readLock writeLock) xmpp + +restartXMPP :: Maybe H.Handle -> XMPP a -> XMPP a +restartXMPP newH xmpp = do + Session oldH ns _ readLock writeLock <- getSession + sax <- liftIO X.newParser + let s = Session (maybe oldH id newH) ns sax readLock writeLock + XMPP (R.local (const s) (unXMPP xmpp)) + +withLock :: (Session -> M.MVar ()) -> XMPP a -> XMPP a +withLock getLock xmpp = do + s <- getSession + let mvar = getLock s + res <- liftIO (M.withMVar mvar (\_ -> runXMPP s xmpp)) + case res of + Left err -> E.throwError err + Right x -> return x + +getSession :: XMPP Session +getSession = XMPP R.ask + +getHandle :: XMPP H.Handle +getHandle = fmap sessionHandle getSession + +liftTLS :: ErrorT Text IO a -> XMPP a +liftTLS io = do + res <- liftIO (runErrorT io) + case res of + Left err -> E.throwError (TransportError err) + Right x -> return x + +putBytes :: ByteString -> XMPP () +putBytes bytes = do + h <- getHandle + liftTLS (H.hPutBytes h bytes) + +putElement :: X.Element -> XMPP () +putElement = putBytes . encodeUtf8 . X.serialiseElement + +putStanza :: S.Stanza a => a -> XMPP () +putStanza = withLock sessionWriteLock . putElement . S.stanzaToElement + +readEvents :: (Integer -> X.Event -> Bool) -> XMPP [X.Event] +readEvents done = xmpp where + xmpp = do + Session h _ p _ _ <- getSession + let nextEvents = do + -- TODO: read in larger increments + bytes <- liftTLS (H.hGetBytes h 1) + let eof = Data.ByteString.null bytes + parsed <- liftIO (X.parse p bytes eof) + case parsed of + Left err -> E.throwError (TransportError err) + Right events -> return events + X.readEvents done nextEvents + +getElement :: XMPP X.Element +getElement = xmpp where + xmpp = do + events <- readEvents endOfTree + case X.eventsToElement events of + Just x -> return x + Nothing -> E.throwError (TransportError "getElement: invalid event list") + + endOfTree 0 (X.EventEndElement _) = True + endOfTree _ _ = False + +getStanza :: XMPP S.ReceivedStanza +getStanza = withLock sessionReadLock $ do + elemt <- getElement + Session _ ns _ _ _ <- getSession + case S.elementToStanza ns elemt of + Just x -> return x + Nothing -> E.throwError (InvalidStanza elemt) diff --git a/lib/Network/Protocol/XMPP/Stanza.hs b/lib/Network/Protocol/XMPP/Stanza.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Protocol/XMPP/Stanza.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- Copyright (C) 2010-2011 John Millikin +-- +-- 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 +-- 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 . + +module Network.Protocol.XMPP.Stanza + ( Stanza (..) + + , ReceivedStanza (..) + , Message (..) + , Presence (..) + , IQ (..) + , MessageType (..) + , PresenceType (..) + , IQType (..) + + , emptyMessage + , emptyPresence + , emptyIQ + + , elementToStanza + ) where + +import Control.Monad (when) +import qualified Data.Text +import Data.Text (Text) +import qualified Network.Protocol.XMPP.XML as X +import Network.Protocol.XMPP.JID (JID, parseJID, formatJID) + +class Stanza a where + stanzaTo :: a -> Maybe JID + stanzaFrom :: a -> Maybe JID + stanzaID :: a -> Maybe Text + stanzaLang :: a -> Maybe Text + stanzaPayloads :: a -> [X.Element] + stanzaToElement :: a -> X.Element + +data ReceivedStanza + = ReceivedMessage Message + | ReceivedPresence Presence + | ReceivedIQ IQ + deriving (Show) + +data Message = Message + { messageType :: MessageType + , messageTo :: Maybe JID + , messageFrom :: Maybe JID + , messageID :: Maybe Text + , messageLang :: Maybe Text + , messagePayloads :: [X.Element] + } + deriving (Show) + +instance Stanza Message where + stanzaTo = messageTo + stanzaFrom = messageFrom + stanzaID = messageID + stanzaLang = messageLang + stanzaPayloads = messagePayloads + stanzaToElement x = stanzaToElement' x "message" typeStr where + typeStr = case messageType x of + MessageNormal -> "normal" + MessageChat -> "chat" + MessageGroupChat -> "groupchat" + MessageHeadline -> "headline" + MessageError -> "error" + +data MessageType + = MessageNormal + | MessageChat + | MessageGroupChat + | MessageHeadline + | MessageError + deriving (Show, Eq) + +emptyMessage :: MessageType -> Message +emptyMessage t = Message + { messageType = t + , messageTo = Nothing + , messageFrom = Nothing + , messageID = Nothing + , messageLang = Nothing + , messagePayloads = [] + } + +data Presence = Presence + { presenceType :: PresenceType + , presenceTo :: Maybe JID + , presenceFrom :: Maybe JID + , presenceID :: Maybe Text + , presenceLang :: Maybe Text + , presencePayloads :: [X.Element] + } + deriving (Show) + +instance Stanza Presence where + stanzaTo = presenceTo + stanzaFrom = presenceFrom + stanzaID = presenceID + stanzaLang = presenceLang + stanzaPayloads = presencePayloads + stanzaToElement x = stanzaToElement' x "presence" typeStr where + typeStr = case presenceType x of + PresenceAvailable -> "" + PresenceUnavailable -> "unavailable" + PresenceSubscribe -> "subscribe" + PresenceSubscribed -> "subscribed" + PresenceUnsubscribe -> "unsubscribe" + PresenceUnsubscribed -> "unsubscribed" + PresenceProbe -> "probe" + PresenceError -> "error" + +data PresenceType + = PresenceAvailable + | PresenceUnavailable + | PresenceSubscribe + | PresenceSubscribed + | PresenceUnsubscribe + | PresenceUnsubscribed + | PresenceProbe + | PresenceError + deriving (Show, Eq) + +emptyPresence :: PresenceType -> Presence +emptyPresence t = Presence + { presenceType = t + , presenceTo = Nothing + , presenceFrom = Nothing + , presenceID = Nothing + , presenceLang = Nothing + , presencePayloads = [] + } + +data IQ = IQ + { iqType :: IQType + , iqTo :: Maybe JID + , iqFrom :: Maybe JID + , iqID :: Maybe Text + , iqLang :: Maybe Text + , iqPayload :: Maybe X.Element + } + deriving (Show) + +instance Stanza IQ where + stanzaTo = iqTo + stanzaFrom = iqFrom + stanzaID = iqID + stanzaLang = iqLang + stanzaPayloads iq = case iqPayload iq of + Just elemt -> [elemt] + Nothing -> [] + stanzaToElement x = stanzaToElement' x "iq" typeStr where + typeStr = case iqType x of + IQGet -> "get" + IQSet -> "set" + IQResult -> "result" + IQError -> "error" + +data IQType + = IQGet + | IQSet + | IQResult + | IQError + deriving (Show, Eq) + +emptyIQ :: IQType -> IQ +emptyIQ t = IQ + { iqType = t + , iqTo = Nothing + , iqFrom = Nothing + , iqID = Nothing + , iqLang = Nothing + , iqPayload = Nothing + } + +stanzaToElement' :: Stanza a => a -> X.Name -> Text -> X.Element +stanzaToElement' stanza name typeStr = X.element name attrs payloads where + payloads = map X.NodeElement (stanzaPayloads stanza) + attrs = concat + [ mattr "to" (fmap formatJID . stanzaTo) + , mattr "from" (fmap formatJID . stanzaFrom) + , mattr "id" stanzaID + , mattr "xml:lang" stanzaLang + , if Data.Text.null typeStr then [] else [("type", typeStr)] + ] + mattr label f = case f stanza of + Nothing -> [] + Just text -> [(label, text)] + +elementToStanza :: Text -> X.Element -> Maybe ReceivedStanza +elementToStanza ns elemt = do + let elemNS = X.nameNamespace (X.elementName elemt) + when (elemNS /= Just ns) Nothing + + let elemName = X.nameLocalName (X.elementName elemt) + case elemName of + "message" -> ReceivedMessage `fmap` parseMessage elemt + "presence" -> ReceivedPresence `fmap` parsePresence elemt + "iq" -> ReceivedIQ `fmap` parseIQ elemt + _ -> Nothing + +parseMessage :: X.Element -> Maybe Message +parseMessage elemt = do + typeStr <- X.attributeText "type" elemt + msgType <- case typeStr of + "normal" -> Just MessageNormal + "chat" -> Just MessageChat + "groupchat" -> Just MessageGroupChat + "headline" -> Just MessageHeadline + "error" -> Just MessageError + _ -> Nothing + msgTo <- xmlJID "to" elemt + msgFrom <- xmlJID "from" elemt + let msgID = X.attributeText "id" elemt + let msgLang = X.attributeText "lang" elemt + let payloads = X.elementChildren elemt + return (Message msgType msgTo msgFrom msgID msgLang payloads) + +parsePresence :: X.Element -> Maybe Presence +parsePresence elemt = do + let typeStr = maybe "" id (X.attributeText "type" elemt) + pType <- case typeStr of + "" -> Just PresenceAvailable + "unavailable" -> Just PresenceUnavailable + "subscribe" -> Just PresenceSubscribe + "subscribed" -> Just PresenceSubscribed + "unsubscribe" -> Just PresenceUnsubscribe + "unsubscribed" -> Just PresenceUnsubscribed + "probe" -> Just PresenceProbe + "error" -> Just PresenceError + _ -> Nothing + + msgTo <- xmlJID "to" elemt + msgFrom <- xmlJID "from" elemt + let msgID = X.attributeText "id" elemt + let msgLang = X.attributeText "lang" elemt + let payloads = X.elementChildren elemt + return (Presence pType msgTo msgFrom msgID msgLang payloads) + +parseIQ :: X.Element -> Maybe IQ +parseIQ elemt = do + typeStr <- X.attributeText "type" elemt + iqType <- case typeStr of + "get" -> Just IQGet + "set" -> Just IQSet + "result" -> Just IQResult + "error" -> Just IQError + _ -> Nothing + + msgTo <- xmlJID "to" elemt + msgFrom <- xmlJID "from" elemt + let msgID = X.attributeText "id" elemt + let msgLang = X.attributeText "lang" elemt + let payload = case X.elementChildren elemt of + [] -> Nothing + child:_ -> Just child + return (IQ iqType msgTo msgFrom msgID msgLang payload) + +xmlJID :: X.Name -> X.Element -> Maybe (Maybe JID) +xmlJID name elemt = case X.attributeText name elemt of + Nothing -> Just Nothing + Just raw -> case parseJID raw of + Just jid -> Just (Just jid) + Nothing -> Nothing diff --git a/lib/Network/Protocol/XMPP/XML.hs b/lib/Network/Protocol/XMPP/XML.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Protocol/XMPP/XML.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- Copyright (C) 2010-2011 John Millikin +-- +-- 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 +-- 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 . + +module Network.Protocol.XMPP.XML + ( module Data.XML.Types + + -- * Constructors + , element + + -- * Misc + , contentText + , escape + , serialiseElement + , readEvents + + -- * libxml-sax-0.4 API imitation + , Parser + , newParser + , parse + , eventsToElement + + ) where + +import Control.Monad (when) +import Data.ByteString (ByteString) +import qualified Data.Text +import Data.Text (Text) +import Data.XML.Types +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import qualified Text.XML.LibXML.SAX as SAX + +contentText :: Content -> Text +contentText (ContentText t) = t +contentText (ContentEntity e) = Data.Text.concat ["&", e, ";"] + +escape :: Text -> Text +escape = Data.Text.concatMap escapeChar where + escapeChar c = case c of + '&' -> "&" + '<' -> "<" + '>' -> ">" + '"' -> """ + '\'' -> "'" + _ -> Data.Text.singleton c + +escapeContent :: Content -> Text +escapeContent (ContentText t) = escape t +escapeContent (ContentEntity e) = Data.Text.concat ["&", escape e, ";"] + +element :: Name -> [(Name, Text)] -> [Node] -> Element +element name attrs children = Element name attrs' children where + attrs' = map (uncurry mkattr) attrs + +mkattr :: Name -> Text -> (Name, [Content]) +mkattr n val = (n, [ContentText val]) + +-- A somewhat primitive serialisation function +-- +-- TODO: better namespace / prefix handling +serialiseElement :: Element -> Text +serialiseElement e = text where + text = Data.Text.concat ["<", eName, " ", attrs, ">", contents, ""] + eName = formatName (elementName e) + formatName = escape . nameLocalName + attrs = Data.Text.intercalate " " (map attr (elementAttributes e ++ nsattr)) + attr (n, c) = Data.Text.concat ([formatName n, "=\""] ++ map escapeContent c ++ ["\""]) + nsattr = case nameNamespace $ elementName e of + Nothing -> [] + Just ns -> [mkattr "xmlns" ns] + contents = Data.Text.concat (map serialiseNode (elementNodes e)) + + serialiseNode (NodeElement e') = serialiseElement e' + serialiseNode (NodeContent c) = escape (contentText c) + serialiseNode (NodeComment _) = "" + serialiseNode (NodeInstruction _) = "" + +-- quick-and-dirty imitation of libxml-sax-0.4 API; later, this should +-- probably be rewritten to use ST and discard the list parsing +data Parser = Parser (SAX.Parser IO) (IORef (Either Text [Event])) + +newParser :: IO Parser +newParser = do + ref <- newIORef (Right []) + p <- SAX.newParserIO Nothing + + let addEvent e = do + x <- readIORef ref + case x of + Left _ -> return () + Right es -> writeIORef ref (Right (e:es)) + return True + + SAX.setCallback p SAX.parsedBeginElement (\name attrs -> addEvent (EventBeginElement name attrs)) + SAX.setCallback p SAX.parsedEndElement (addEvent . EventEndElement) + SAX.setCallback p SAX.parsedCharacters (addEvent . EventContent . ContentText) + SAX.setCallback p SAX.parsedComment (addEvent . EventComment) + SAX.setCallback p SAX.parsedInstruction (addEvent . EventInstruction) + SAX.setCallback p SAX.reportError (\err -> writeIORef ref (Left err) >> return False) + + return (Parser p ref) + +parse :: Parser -> ByteString -> Bool -> IO (Either Text [Event]) +parse (Parser p ref) bytes finish = do + writeIORef ref (Right []) + SAX.parseBytes p bytes + when finish (SAX.parseComplete p) + eitherEvents <- readIORef ref + return $ case eitherEvents of + Left err -> Left err + Right events -> Right (reverse events) + +readEvents :: Monad m + => (Integer -> Event -> Bool) + -> m [Event] + -> m [Event] +readEvents done nextEvents = readEvents' 0 [] where + readEvents' depth acc = do + events <- nextEvents + let (done', depth', acc') = step events depth acc + if done' + then return acc' + else readEvents' depth' acc' + + step [] depth acc = (False, depth, acc) + step (e:es) depth acc = let + depth' = depth + case e of + (EventBeginElement _ _) -> 1 + (EventEndElement _) -> (- 1) + _ -> 0 + acc' = e : acc + in if done depth' e + then (True, depth', reverse acc') + else step es depth' acc' + +-- | Convert a list of events to a single 'Element'. If the events do not +-- contain at least one valid element, 'Nothing' will be returned instead. +eventsToElement :: [Event] -> Maybe Element +eventsToElement es = case eventsToNodes es >>= isElement of + (e:_) -> Just e + _ -> Nothing + +eventsToNodes :: [Event] -> [Node] +eventsToNodes = concatMap blockToNodes . splitBlocks + +-- Split event list into a sequence of "blocks", which are the events including +-- and between a pair of tags. and are both +-- single blocks. +splitBlocks :: [Event] -> [[Event]] +splitBlocks es = ret where + (_, _, ret) = foldl splitBlocks' (0, [], []) es + + splitBlocks' (depth, accum, allAccum) e = split where + split = if depth' == 0 + then (depth', [], allAccum ++ [accum']) + else (depth', accum', allAccum) + accum' = accum ++ [e] + depth' :: Integer + depth' = depth + case e of + (EventBeginElement _ _) -> 1 + (EventEndElement _) -> (- 1) + _ -> 0 + +blockToNodes :: [Event] -> [Node] +blockToNodes [] = [] +blockToNodes (begin:rest) = nodes where + end = last rest + nodes = case (begin, end) of + (EventBeginElement name attrs, EventEndElement _) -> [node name attrs] + (EventContent c, _) -> [NodeContent c] + _ -> [] + + node n as = NodeElement (Element n as (eventsToNodes (init rest))) diff --git a/license.txt b/license.txt new file mode 100644 --- /dev/null +++ b/license.txt @@ -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/network-protocol-xmpp.cabal b/network-protocol-xmpp.cabal --- a/network-protocol-xmpp.cabal +++ b/network-protocol-xmpp.cabal @@ -1,28 +1,34 @@ name: network-protocol-xmpp -version: 0.4 -synopsis: Client->Server XMPP +version: 0.4.1 license: GPL-3 -license-file: License.txt -author: John Millikin - Stephan Maka -maintainer: jmillikin@gmail.com +license-file: license.txt +author: John Millikin , Stephan Maka +maintainer: John Millikin build-type: Simple -cabal-version: >=1.6 +cabal-version: >= 1.6 category: Network stability: experimental +homepage: https://john-millikin.com/software/haskell-xmpp/ bug-reports: mailto:jmillikin@gmail.com -homepage: https://john-millikin.com/software/hs-xmpp/ -tested-with: GHC==6.12.1 +synopsis: Client library for the XMPP protocol. +description: + source-repository head type: bazaar - location: https://john-millikin.com/software/hs-xmpp/ + location: https://john-millikin.com/branches/network-protocol-xmpp/0.4/ +source-repository this + type: bazaar + location: https://john-millikin.com/branches/network-protocol-xmpp/0.4/ + tag: network-protocol-xmpp_0.4.1 + library - ghc-options: -Wall + ghc-options: -Wall -O2 + hs-source-dirs: lib build-depends: - base >= 3 && < 5 + base >= 4.0 && < 5.0 , text >= 0.10 && < 0.12 , gnuidn >= 0.2 && < 0.3 , gnutls >= 0.1 && < 0.3