diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -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/COPYING.LESSER b/COPYING.LESSER new file mode 100644 --- /dev/null +++ b/COPYING.LESSER @@ -0,0 +1,165 @@ + GNU LESSER 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. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser 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 +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/Examples/EchoClient.hs b/Examples/EchoClient.hs --- a/Examples/EchoClient.hs +++ b/Examples/EchoClient.hs @@ -1,73 +1,121 @@ {- -This file (EchoClient.hs) illustrates how to connect, authenticate and set a -presence with Pontarius XMPP. The contents of this file may be used freely, as -if it is in the public domain. +Copyright © 2010-2011 Jon Kristensen. +This file (EchoClient.hs) illustrates how to connect, authenticate, set a +presence, and echo messages with Pontarius XMPP. The contents of this file may +be used freely, as if it is in the public domain. + +In any state-aware function (function operating in the StateT monad) you can get +and set the current by writing + +@CMS.get >>= \ state -> CMS.put $ state { stateTest = 10 } ...@ + +or, if you prefer the do-notation, + +@do + state <- CMS.get + CMS.put $ state { stateTest = 10 } + ...@ + -} +{-# LANGUAGE MultiParamTypeClasses #-} + + import Network.XMPP -import Control.Concurrent.Chan (Chan, readChan, writeChan) -import Data.Maybe -import Data.XML.Types -import qualified Data.Text as DT +import qualified Control.Monad as CM +import qualified Control.Monad.State as CMS +import qualified Control.Monad.IO.Class as CMIC +import qualified Data.Maybe as DM -- Account and server details. -host = "test.pontarius.org" -userName = "sprint3-xmpp" -server = "test.pontarius.org" -port = 5222 +hostName = "jonkristensen.com" +userName = "pontarius" +serverIdentifier = "jonkristensen.com" +portNumber = 5222 resource = "echo-client" password = "" --- Creates a Pontarius XMPP session and requests to connect. +-- The client state, containing the required Pontarius XMPP Session object. It +-- also contains a dummy integer value to illustrate how client states are used. +data State = State { stateSession :: Maybe (Session State IO) + , stateTest :: Integer } + +defaultState :: State + +defaultState = State { stateSession = Nothing + , stateTest = 5 } + + +instance ClientState State IO where + putSession st se = st { stateSession = Just se } + + +-- This client defines one client handler, and only specifies the +-- messageReceived callback. + +clientHandlers = [ClientHandler { messageReceived = Just messageReceived_ + , presenceReceived = Nothing + , iqReceived = Nothing + , sessionTerminated = Nothing }] + + +-- The main function sets up the Pontarius XMPP session with the default client +-- state and client handler defined above, as well as specifying that the +-- sessionCreated function should be called when the session has been created. + main :: IO () -main = - do (inEvents, outEvents) <- createSession - writeChan outEvents $ XOEConnect host port - loop inEvents outEvents +main = do + createSession + defaultState + clientHandlers + sessionCreated --- All "in" events (incoming events to this program, events from Pontarius XMPP) --- are being processed in this loop. A state variable could be added here. -loop :: Chan XMPPInEvent -> Chan XMPPOutEvent -> IO () -loop c c_ = - do e <- readChan c - -- putStrLn $ "XMPPInEvent received: " ++ (show e) - processEvent e - loop c c_ - where - processEvent :: XMPPInEvent -> IO () - - -- When connected, authenticate - processEvent XIEConnectionSucceeded = - writeChan c_ $ XOEAuthenticate userName password resource - - -- When authenticated, set presence - processEvent XIEAuthenticationSucceeded = - writeChan c_ $ XOEPresence $ - presence Nothing Nothing Nothing Nothing Available [] - - -- Auto-accept subscriptions when asked and ask for subscription - processEvent (XIEPresence (Presence { presenceStanza = stanza - , presenceType = Subscribe })) = do - let jid = stanzaFrom stanza - writeChan c_ $ XOEPresence $ presence Nothing Nothing jid Nothing - Subscribed [] - writeChan c_ $ XOEPresence $ presence Nothing Nothing jid Nothing - Subscribe [] +-- The session has been created. Let's try to open the XMPP stream! + +sessionCreated :: CMS.StateT State IO () + +sessionCreated = do + state <- CMS.get + connect (DM.fromJust $ stateSession state) hostName portNumber + (Just ("", \ x -> True)) (Just (userName, password, Just resource)) + connectCallback + return () + + +-- We have tried to connected, TLS secured and authenticated! + +connectCallback :: ConnectResult -> CMS.StateT State IO () + +connectCallback r = do + state <- CMS.get + case r of + ConnectSuccess _ _ _ -> do + sendPresence (DM.fromJust $ stateSession state) + (presence Nothing Nothing Nothing Nothing Available []) + _ -> do + CMIC.liftIO $ putStrLn "Could not connect." return () - - -- Echo messages - processEvent (XIEMessage m) = - writeChan c_ $ XOEMessage $ - message Nothing Nothing (stanzaFrom $ messageStanza m) Nothing - (messageType m) (messagePayload m) - processEvent _ = return () + + +-- A message (stanza) has been received. Let's echo it! + +messageReceived_ :: Message -> CMS.StateT State IO Bool + +messageReceived_ m = do + state <- CMS.get + CMIC.liftIO $ putStrLn $ + "Received a message; echoing it! By the way: Internal state is " ++ + (show $ stateTest state) ++ "." + sendMessage (DM.fromJust $ stateSession state) $ message Nothing Nothing + (stanzaFrom $ messageStanza m) Nothing (messageType m) (messagePayload m) + return True diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,28 +1,4 @@ -Copyright © 2010-2011, Jon Kristensen - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - - * Neither the name of Pontarius, Pontarius XMPP nor the names of its - contributors may be used to endorse or promote products derived from this - software without specific prior written permission. +Copyright © 2010-2011, Jon Kristensen. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, -INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, -BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY -OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, -EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Pontarius XMPP is licensed under GNU Lesser General Public License, version 3. +See COPYING and COPYING.LESSER for more information. diff --git a/Network/XMPP.hs b/Network/XMPP.hs --- a/Network/XMPP.hs +++ b/Network/XMPP.hs @@ -1,7 +1,28 @@ +{- + +Copyright © 2010-2011 Jon Kristensen. + +This file is part of Pontarius XMPP. + +Pontarius XMPP is free software: you can redistribute it and/or modify it under +the terms of the GNU Lesser General Public License as published by the Free +Software Foundation, either version 3 of the License, or (at your option) any +later version. + +Pontarius XMPP 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 Lesser General Public License for more +details. + +You should have received a copy of the GNU Lesser General Public License along +with Pontarius XMPP. If not, see . + +-} + -- | Module: $Header$ -- Description: A minimalistic and easy-to-use XMPP library -- Copyright: Copyright © 2010-2011 Jon Kristensen --- License: BSD-3 +-- License: LGPL-3 -- -- Maintainer: info@pontarius.org -- Stability: unstable @@ -13,7 +34,7 @@ -- Note that we are not recommending anyone to use Pontarius XMPP at this time -- as it's still in an experimental stage and will have its API and data types -- modified frequently. See the project's web site at --- for more information. +-- for more information. -- -- This module will be documented soon. @@ -29,9 +50,28 @@ , replyToChallenge1 -- Network.XMPP.Session - , XMPPInEvent (..) - , XMPPOutEvent (..) + , Certificate + , ClientHandler (..) + , ClientState (..) + , ConnectResult (..) + , HostName + , Password + , PortNumber + , Resource + , Session + , TerminationReason + , UserName + , sendIQ + , sendPresence + , sendMessage + , connect + , openStream + , secureWithTLS + , authenticate , createSession + , OpenStreamResult (..) + , SecureWithTLSResult (..) + , AuthenticateResult (..) -- Network.XMPP.Stanza , StanzaID (SID) @@ -52,11 +92,13 @@ , iqStanza , iqPayloadNamespace , iqPayload - + , getId + , iqAck + -- Network.XMPP.Utilities , elementToString , elementsToString - , getID + , getID -- Genrate an Id with 8 char , getID_ ) where import Network.XMPP.JID diff --git a/Network/XMPP/JID.hs b/Network/XMPP/JID.hs --- a/Network/XMPP/JID.hs +++ b/Network/XMPP/JID.hs @@ -1,7 +1,28 @@ +{- + +Copyright © 2010-2011 Jon Kristensen. + +This file is part of Pontarius XMPP. + +Pontarius XMPP is free software: you can redistribute it and/or modify it under +the terms of the GNU Lesser General Public License as published by the Free +Software Foundation, either version 3 of the License, or (at your option) any +later version. + +Pontarius XMPP 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 Lesser General Public License for more +details. + +You should have received a copy of the GNU Lesser General Public License along +with Pontarius XMPP. If not, see . + +-} + -- | Module: $Header$ -- Description: JabberID (JID) data type and utility functions -- Copyright: Copyright © 2010-2011 Jon Kristensen --- License: BSD-3 +-- License: LGPL-3 -- -- Maintainer: info@pontarius.org -- Stability: unstable diff --git a/Network/XMPP/SASL.hs b/Network/XMPP/SASL.hs --- a/Network/XMPP/SASL.hs +++ b/Network/XMPP/SASL.hs @@ -1,3 +1,24 @@ +{- + +Copyright © 2010-2011 Jon Kristensen. + +This file is part of Pontarius XMPP. + +Pontarius XMPP is free software: you can redistribute it and/or modify it under +the terms of the GNU Lesser General Public License as published by the Free +Software Foundation, either version 3 of the License, or (at your option) any +later version. + +Pontarius XMPP 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 Lesser General Public License for more +details. + +You should have received a copy of the GNU Lesser General Public License along +with Pontarius XMPP. If not, see . + +-} + -- TODO: Make it possible to include host. -- TODO: Host is assumed to be ISO 8859-1; make list of assumptions. -- TODO: Can it contain newline characters? diff --git a/Network/XMPP/Session.hs b/Network/XMPP/Session.hs --- a/Network/XMPP/Session.hs +++ b/Network/XMPP/Session.hs @@ -1,906 +1,1225 @@ --- | Module: $Header$ --- Description: XMPP client session management module --- Copyright: Copyright © 2010-2011 Jon Kristensen --- License: BSD-3 --- --- Maintainer: info@pontarius.org --- Stability: unstable --- Portability: portable --- --- This module will be documented soon. - --- TODO: Send white-space characters with regular intervals to keep the --- connection alive. --- TODO: Add namespace support for stream/features? --- TODO: Add support for `ver optional' support for features? --- TODO: Presence priority? --- TODO: Stop the logger --- TODO: Catch errors - -module Network.XMPP.Session ( XMPPInEvent (..) - , XMPPOutEvent (..) - , createSession ) where - - -import Network.XMPP.JID -import Network.XMPP.SASL -import Network.XMPP.Stanza -import Network.XMPP.Utilities - -import Codec.Binary.UTF8.String -import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) -import Control.Concurrent (forkIO, threadDelay) -import Control.Monad.IO.Class (liftIO, MonadIO) -import Data.Enumerator (($$), Iteratee, continue, joinI, - run_, yield) -import Data.Enumerator.Binary (enumHandle, enumFile) -import Data.Maybe -import Data.String -import Data.XML.Types -import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput) -import Network -import Network.TLS -import Network.TLS.Cipher -import System.IO (BufferMode, BufferMode(NoBuffering)) -import System.Log.HLogger -import System.Log.SimpleHLogger -import Text.XML.Enumerator.Parse (parseBytes, decodeEntities) -import Text.XML.Enumerator.Document (fromEvents) -import qualified Codec.Binary.Base64.String as CBBS -import qualified Data.ByteString as DB -import qualified Data.ByteString.Lazy as DBL (ByteString, append, pack, fromChunks, toChunks, null) -import qualified Data.ByteString.Lazy.Char8 as DBLC (append, pack, unpack) -import qualified Data.Enumerator as E -import qualified Data.Enumerator.List as EL -import qualified Data.List as DL -import qualified Data.Text as DT -import qualified Data.Text.Lazy as DTL - - -type Server = String -type Port = Integer - -type UserName = String -type Password = String -type Resource = String - - -data XMPPInEvent = XIEConnectionSucceeded | - XIEConnectionFailed | - XIEAuthenticationSucceeded | - XIEAuthenticationFailed | - XIEMessage Message | - XIEPresence Presence | - XIEIQ IQ | - -- XIEIQJingle | -- Added for Jingle sessions - -- XIEIQXTLS | -- Added for XTLS connection - XIEDisconnect deriving (Eq, Show) - -data XMPPOutEvent = XOEConnect Server Port | - XOEAuthenticate UserName Password Resource | - XOEMessage Message | - XOEPresence Presence | - XOEIQ IQ | - -- XOEIQJingle | -- Added for Jingle sessions - -- XOEIQXTLS | -- Added for XTLS connection - XOEDisconnect deriving (Eq, Show) - - -data SecurityEvent = TLSSucceeded TLSCtx | TLSFailed - - -instance Show SecurityEvent where - show (TLSSucceeded _) = "TLSSucceeded Ctx" - show TLSFailed = "TLSFailed" - - -data ConnectionState = Disconnected | - ConnectedNotTLSSecured | - ConnectedTLSSecured TLSCtx - -instance Eq ConnectionState where - (==) Disconnected Disconnected = True - (==) ConnectedNotTLSSecured ConnectedNotTLSSecured = True - (==) (ConnectedTLSSecured _) (ConnectedTLSSecured _) = True - (==) _ _ = False - -data AuthenticationState = AuthNotRequested | - AuthRequested | - Challenge1Processed | - Authenticated deriving (Eq) - -data State = State { stateConnectionState :: ConnectionState - , stateAuthenticationState :: AuthenticationState - , stateHandle :: Maybe Handle - , stateServer :: Maybe (Server, Port) - , stateUserName :: Maybe String - , statePassword :: Maybe String - , stateResource :: Maybe String - , stateStreamID :: Maybe String } - -defaultState = State { stateConnectionState = Disconnected - , stateAuthenticationState = AuthNotRequested - , stateHandle = Nothing - , stateServer = Nothing - , stateUserName = Nothing - , statePassword = Nothing - , stateResource = Nothing - , stateStreamID = Nothing } - - --- An XMLEvent is a high-level XMPP event generated by our XML parsing code. - -data XMLEvent = XEBeginStream Stream | XEFeatures Features | - XEChallenge Challenge | XESuccess Success | - XEEndStream | XEIQ IQ | XEPresence Presence | - XEMessage Message | XEOther String deriving (Show) - - --- Represents the top-level "" element. - -data Stream = Stream { streamNamespace :: StreamNamespace - , streamID :: String - , streamVersion :: Float } deriving (Show) - - --- TODO: Do not make this assumption, but parse the element instead. - -defaultStream id = Stream { streamNamespace = Client - , streamID = id - , streamVersion = 1.0 } - - --- The "" element. - -data Features = Features { featuresStartTLS :: Bool - , featuresMechanisms :: [FeaturesMechanism] - , featuresCompressionMethods :: [CompressionMethod] } deriving (Show) - - --- TODO: Do not make this assumption, but parse the element instead. - -featuresDefault = Features { featuresStartTLS = True, - featuresMechanisms = [DigestMD5], - featuresCompressionMethods = [] } - - --- TODO: Necessary? - -data StreamNamespace = Client | Server deriving (Show) - - --- Authentication mechanisms. We only support DigestMD5 at this point. - -data FeaturesMechanism = DigestMD5 | CramMD5 | Login | Plain | UnknownMechanism deriving (Show) - -data UnknownMechanism = UM String deriving (Show) - - -data CompressionMethod = Zlib deriving (Show) - - --- Containers for information from SASL challenges and successes. - -data Challenge = Chal String deriving (Show) - -data Success = Succ String deriving (Show) - - -data InternalEvent = IEX XMLEvent | - IEO XMPPOutEvent | - IES SecurityEvent deriving (Show) - - --- | Creates a Pontarius XMPP session by setting up internal processes and state --- and creates the two (in and out) event channels that the XMPP client uses --- for communicating with Pontarius XMPP. - -createSession :: IO (Chan XMPPInEvent, Chan XMPPOutEvent) - -createSession = do - logger <- simpleLogger "PontariusXMPP" - loggerLog logger (Just ("Session", "createSession")) Info "Pontarius XMPP has started" - - -- Create client "in" and "out" channels (naming from the perspective of the - -- XMPP client) as well as the internal event channel used by the state loop - inChan <- newChan - outChan <- newChan - internalChan <- newChan - - -- Start to listen to client "out" events (client actions) - forkIO $ clientListener outChan internalChan logger - - -- Start the state loop, the main loop of Pontarius XMPP - forkIO $ stateLoop defaultState internalChan inChan logger - - return (inChan, outChan) - - --- Receives events from the XMPP client and forwards them to the state loop by --- using the internal event channel. - -clientListener :: Chan XMPPOutEvent -> Chan InternalEvent -> Logger -> IO () - -clientListener c c_ l = - do event <- readChan c - loggerLog l (Just ("Session", "clientListener")) Debug $ "clientListener: Forwarding received client event: " ++ show (event) - writeChan c_ (IEO event) - clientListener c c_ l - - --- Processes internal events to possibly perform actions and update the session --- state. Note that the InternalEvent type wraps the external client events. - -stateLoop :: State -> Chan InternalEvent -> Chan XMPPInEvent -> Logger -> IO () - -stateLoop s c c_ l = - do event <- readChan c - -- logDebug l $ "stateLoop: Received event: " ++ (show event) - -- TODO: Debug with state? - s' <- processEvent event - stateLoop s' c c_ l - where - connectionState = stateConnectionState s - authenticationState = stateAuthenticationState s - handle = stateHandle s - server = stateServer s - userName = stateUserName s - password = statePassword s - resource = stateResource s - streamID = stateStreamID s - Just (serverHost, serverPort) = stateServer s - tlsCtx = let ConnectedTLSSecured x = connectionState in x - - -- let xml = clientOutEventToXML clientEvent - -- logDebug l $ "processEvent: Sending XML: " ++ xml - -- sendData (fromJust tlsCtx) $ DBLC.pack $ encodeString $ xml - - processEvent (IEO clientOutEvent) = do - loggerLog l (Just ("Session", "processEvent")) Debug $ "Processing client out event " ++ (show clientOutEvent) - case clientOutEvent of - XOEConnect serverHost_ serverPort_ -> do - handle <- connectTo serverHost_ (PortNumber $ fromInteger serverPort_) - hSetBuffering handle NoBuffering - hPutStr handle $ encodeString $ - "" - hFlush handle - - -- Start XML enumerator, which will read from the handle to generate the - -- relevant internal events - forkIO $ xmlEnumerator c handle serverHost_ l - - return s { stateConnectionState = ConnectedNotTLSSecured - , stateHandle = Just handle - , stateServer = Just (serverHost_, serverPort_) } - - -- TODO: Function to verify certificate? - XOEAuthenticate userName_ password_ resource_ -> do - sendData tlsCtx $ DBLC.pack $ encodeString - "" - return s { stateAuthenticationState = AuthRequested - , stateUserName = Just userName_ - , statePassword = Just password_ - , stateResource = Just resource_ } - - XOEPresence presence -> do - presence' <- case stanzaID $ presenceStanza presence of - Nothing -> do - id <- getID - return $ presence { presenceStanza = (presenceStanza presence) { stanzaID = Just (SID id) } } - _ -> return presence - - let xml = presenceToXML presence' - loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Will send presence XML: " ++ xml - sendData tlsCtx $ DBLC.pack $ encodeString $ xml - return s - - XOEMessage message -> do - message' <- case stanzaID $ messageStanza message of - Nothing -> do - id <- getID - return $ message { messageStanza = (messageStanza message) { stanzaID = Just (SID id) } } - _ -> return message - - let xml = messageToXML message' - loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Will send message XML: " ++ xml - sendData tlsCtx $ DBLC.pack $ encodeString $ xml - return s - - XOEIQ iq -> do - iq' <- case stanzaID $ iqStanza iq of - Nothing -> do - id <- getID - return $ case iq of - IQGet {} -> do - iq { iqGetStanza = (iqStanza iq) { stanzaID = Just (SID id) } } - IQSet {} -> do - iq { iqSetStanza = (iqStanza iq) { stanzaID = Just (SID id) } } - IQResult {} -> do - iq { iqResultStanza = (iqStanza iq) { stanzaID = Just (SID id) } } - _ -> return iq - - let xml = iqToXML iq' - loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Will send IQ XML: " ++ xml - sendData tlsCtx $ DBLC.pack $ encodeString $ xml - return s - - XOEDisconnect -> do - -- TODO: Close stream - return s - - -- TODO: processEvent (IES TLSFailed) = - - processEvent (IES (TLSSucceeded receivedTLSCtx)) = - return (s { stateConnectionState = ConnectedTLSSecured receivedTLSCtx }) - - -- A element has begun - -- TODO: Parse the XEStreamBegin object - processEvent (IEX (XEBeginStream _)) = do - loggerLog l (Just ("Session", "processEvent")) Debug "processEvent: A new stream has been opened" - return s - - -- We have received on an insecure stream - -- TODO: Parse the XEFeatures object - processEvent (IEX (XEFeatures _)) - | connectionState == ConnectedNotTLSSecured = do - loggerLog l (Just ("Session", "processEvent")) Debug $ - "processEvent: Received features ([...]) on insecure stream; req" ++ - "uesting \"starttls\"" - hPutStr (fromJust handle) $ - "" - hFlush (fromJust handle) - return s - - -- We have received on a secure and non-authenticated stream - processEvent (IEX (XEFeatures _)) - | connectionState == ConnectedTLSSecured tlsCtx && - authenticationState /= Authenticated = do - loggerLog l (Just ("Session", "processEvent")) Debug $ - "processEvent: Received features ([...]) on an unauthenticated" ++ - " secure stream" - writeChan c_ $ XIEConnectionSucceeded - return s - - -- We have received on an authenticated secure stream; we are - -- now ready to start processing client events - processEvent (IEX (XEFeatures _)) - | connectionState == ConnectedTLSSecured tlsCtx = do - loggerLog l (Just ("Session", "processEvent")) Debug $ - "processEvent: Received features ([...]) on an authenticated sec" ++ - "ure stream" - loggerLog l (Just ("Session", "processEvent")) Info $ "processEvent: User has successfully logged in" - case resource of - Nothing -> do - sendData tlsCtx $ DBLC.pack $ encodeString - "" - return () - _ -> do - loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Setting resource: " ++ - (fromJust resource) - sendData tlsCtx $ DBLC.pack $ encodeString - "" ++ fromJust resource ++ - "" - return () - r <- getID - sendData tlsCtx $ DBLC.pack $ encodeString $ - "" ++ - "" - writeChan c_ $ XIEAuthenticationSucceeded - return (s { stateAuthenticationState = Authenticated }) - - -- We have received a SASL challenge on a secure stream - processEvent (IEX (XEChallenge (Chal challenge))) - | connectionState == ConnectedTLSSecured tlsCtx = do - let challenge' = CBBS.decode challenge - case authenticationState of - AuthRequested -> do - -- This is the first challenge - we need to calculate the reply - loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Received initial challenge: " ++ - challenge ++ " (or " ++ challenge' ++ ")" - random <- getID -- TODO: Length and content. - case replyToChallenge1 challenge' serverHost (fromJust userName) - (fromJust password) random of - Left reply -> do - let reply' = (filter (/= '\n') (CBBS.encode reply)) - loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Sending challenge response: " ++ - reply' - sendData tlsCtx $ DBLC.pack $ encodeString $ - "" ++ - reply' ++ "" - return (s { stateAuthenticationState = Challenge1Processed } ) - Right error -> do - putStrLn $ show error - return s - Challenge1Processed -> do - -- This is not the first challenge; [...] - -- TODO: Can we assume "rspauth"? - loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Received non-initial challenge: " ++ - challenge ++ " (or " ++ challenge' ++ ")" - liftIO $ sendData tlsCtx $ DBLC.pack $ encodeString $ - "" - return s - - -- We have received a SASL "success" message over a secured connection - -- TODO: Parse the success message? - -- TODO: ? - processEvent (IEX (XESuccess (Succ _))) - | connectionState == ConnectedTLSSecured tlsCtx = do - loggerLog l (Just ("Session", "processEvent")) Debug $ - "processEvent: Received authentication success: [...]; restartin" ++ - "g stream" -- TODO - sendData tlsCtx $ DBLC.pack $ - encodeString "" - return s { stateAuthenticationState = Authenticated } - - -- Ignore id="bind_1" and session IQ result, otherwise create client event - processEvent (IEX (XEIQ iqEvent)) - | authenticationState == Authenticated = do - case shouldIgnoreIQ iqEvent of - True -> - return s - False -> do - loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Got IQ for client: " ++ - (show iqEvent) - writeChan c_ $ XIEIQ iqEvent - return s - - processEvent (IEX (XEPresence presenceEvent)) - | authenticationState == Authenticated = do - loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Got presence for client: " ++ - (show presenceEvent) - writeChan c_ $ XIEPresence presenceEvent - return s - - processEvent (IEX (XEMessage messageEvent)) = do - loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Got message for client: " ++ - (show messageEvent) - writeChan c_ $ XIEMessage messageEvent - return s - - -- We received an XML element that we didn't parse - processEvent (IEX xmlEvent) = do - loggerLog l (Just ("Session", "processEvent")) Warning $ "processEvent: XML event slipped through: " ++ - (show xmlEvent) - return s - - shouldIgnoreIQ :: IQ -> Bool - shouldIgnoreIQ i = case iqPayload i of - Nothing -> False - Just e -> case nameNamespace $ elementName e of - Just x | x == DT.pack "urn:ietf:params:xml:ns:xmpp-bind" -> True - Just x | x == DT.pack "urn:ietf:params:xml:ns:xmpp-session" -> True - Just _ -> False - Nothing -> False - -parseIQ :: Element -> IQ -parseIQ e | typeAttr == "get" = let (Just payloadMust) = payload - in iqGet idAttr fromAttr toAttr Nothing - payloadMust - | typeAttr == "set" = let (Just payloadMust) = payload - in iqSet idAttr fromAttr toAttr Nothing - payloadMust - | typeAttr == "result" = iqResult idAttr fromAttr toAttr Nothing - payload - - where - -- TODO: Many duplicate functions from parsePresence. - - payload :: Maybe Element - payload = case null (elementChildren e) of - True -> Nothing - False -> Just $ head $ elementChildren e - - typeAttr :: String - typeAttr = case attributeText typeName e of - -- Nothing -> Nothing - Just a -> DT.unpack a - - fromAttr :: Maybe JID - fromAttr = case attributeText fromName e of - Nothing -> Nothing - Just a -> stringToJID $ DT.unpack a - - toAttr :: Maybe JID - toAttr = case attributeText toName e of - Nothing -> Nothing - Just a -> stringToJID $ DT.unpack a - - idAttr :: Maybe StanzaID - idAttr = case attributeText idName e of - Nothing -> Nothing - Just a -> Just (SID (DT.unpack a)) - - typeName :: Name - typeName = fromString "type" - - fromName :: Name - fromName = fromString "from" - - toName :: Name - toName = fromString "to" - - idName :: Name - idName = fromString "id" - --- TODO: Parse xml:lang - -parsePresence :: Element -> Presence -parsePresence e = presence idAttr fromAttr toAttr Nothing typeAttr (elementChildren e) - where - -- TODO: Many duplicate functions from parseIQ. - - typeAttr :: PresenceType - typeAttr = case attributeText typeName e of - Just t -> stringToPresenceType $ DT.unpack t - Nothing -> Available - - fromAttr :: Maybe JID - fromAttr = case attributeText fromName e of - Nothing -> Nothing - Just a -> stringToJID $ DT.unpack a - - toAttr :: Maybe JID - toAttr = case attributeText toName e of - Nothing -> Nothing - Just a -> stringToJID $ DT.unpack a - - idAttr :: Maybe StanzaID - idAttr = case attributeText idName e of - Nothing -> Nothing - Just a -> Just (SID (DT.unpack a)) - - fromName :: Name - fromName = fromString "from" - - typeName :: Name - typeName = fromString "type" - - toName :: Name - toName = fromString "to" - - idName :: Name - idName = fromString "id" - -parseMessage :: Element -> Message -parseMessage e = message idAttr fromAttr toAttr Nothing typeAttr (elementChildren e) - where - -- TODO: Many duplicate functions from parseIQ. - - typeAttr :: MessageType - typeAttr = case attributeText typeName e of - Just t -> stringToMessageType $ DT.unpack t - Nothing -> Normal - - fromAttr :: Maybe JID - fromAttr = case attributeText fromName e of - Nothing -> Nothing - Just a -> stringToJID $ DT.unpack a - - toAttr :: Maybe JID - toAttr = case attributeText toName e of - Nothing -> Nothing - Just a -> stringToJID $ DT.unpack a - - idAttr :: Maybe StanzaID - idAttr = case attributeText idName e of - Nothing -> Nothing - Just a -> Just (SID (DT.unpack a)) - - fromName :: Name - fromName = fromString "from" - - typeName :: Name - typeName = fromString "type" - - toName :: Name - toName = fromString "to" - - idName :: Name - idName = fromString "id" - --- stringToPresenceType "available" = Available --- stringToPresenceType "away" = Away --- stringToPresenceType "chat" = Chat --- stringToPresenceType "dnd" = DoNotDisturb --- stringToPresenceType "xa" = ExtendedAway - -stringToPresenceType "probe" = Probe -stringToPresenceType "error" = PresenceError - -stringToPresenceType "unavailable" = Unavailable -stringToPresenceType "subscribe" = Subscribe -stringToPresenceType "subscribed" = Subscribed -stringToPresenceType "unsubscribe" = Unsubscribe -stringToPresenceType "unsubscribed" = Unsubscribed - --- presenceTypeToString Available = "available" - --- presenceTypeToString Away = "away" --- presenceTypeToString Chat = "chat" --- presenceTypeToString DoNotDisturb = "dnd" --- presenceTypeToString ExtendedAway = "xa" - -presenceTypeToString Unavailable = "unavailable" - -presenceTypeToString Probe = "probe" -presenceTypeToString PresenceError = "error" - -presenceTypeToString Subscribe = "subscribe" -presenceTypeToString Subscribed = "subscribed" -presenceTypeToString Unsubscribe = "unsubscribe" -presenceTypeToString Unsubscribed = "unsubscribed" - -stringToMessageType "chat" = Chat -stringToMessageType "error" = MessageError -stringToMessageType "groupchat" = Groupchat -stringToMessageType "headline" = Headline -stringToMessageType "normal" = Normal -stringToMessageType s = OtherMessageType s - -messageTypeToString Chat = "chat" -messageTypeToString MessageError = "error" -messageTypeToString Groupchat = "groupchat" -messageTypeToString Headline = "headline" -messageTypeToString Normal = "normal" -messageTypeToString (OtherMessageType s) = s - -xmlEnumerator :: Chan InternalEvent -> Handle -> String -> Logger -> IO () -xmlEnumerator c h s l = do - loggerLog l (Just ("Session", "processEvent")) Debug $ "xmlEnumerator: Starting to read insecure XML" - run_ $ enumHandle 1 h $$ joinI $ parseBytes decodeEntities - $$ xmlReader c [] 0 - loggerLog l (Just ("Session", "processEvent")) Debug $ "xmlEnumerator: Unsecure stream ended - performing TLS handshake" - t <- handshake' h s - case t of - Just tlsctx -> do loggerLog l (Just ("Session", "processEvent")) Debug $ "xmlEnumerator: Handshake successful - st" ++ - "arting to read secure XML" - writeChan c (IES (TLSSucceeded tlsctx)) - run_ $ enumTLS tlsctx $$ joinI $ parseBytes decodeEntities - $$ xmlReader c [] 0 - loggerLog l (Just ("Session", "processEvent")) Debug $ - "xmlEnumerator: Secure stream ended, exiting" - return () - Nothing -> loggerLog l (Just ("Session", "processEvent")) Debug $ "xmlEnumerator: TLS handshake failed" -- TODO: Event - return () - -enumTLS :: TLSCtx -> E.Enumerator DB.ByteString IO b -enumTLS c s = loop c s where - loop :: TLSCtx -> E.Step DB.ByteString IO b -> E.Iteratee DB.ByteString IO b - loop c (E.Continue k) = - do d <- recvData c - case DBL.null d of - True -> loop c (E.Continue k) - False -> k (E.Chunks $ DBL.toChunks d) E.>>== loop c - loop _ step = E.returnI step - -hPutStr' :: Handle -> String -> IO () -hPutStr' h s = do - hPutStr h $ encodeString "" - hFlush h - -getTLSParams :: TLSParams -getTLSParams = TLSParams { pConnectVersion = TLS10 - , pAllowedVersions = [TLS10,TLS11] - , pCiphers = [cipher_AES256_SHA1] -- Check the rest - , pCompressions = [nullCompression] - , pWantClientCert = False - , pCertificates = [] - , onCertificatesRecv = \_ -> return True } -- Verify cert chain - -handshake' :: Handle -> String -> IO (Maybe TLSCtx) -handshake' h s = do - let t = getTLSParams - r <- makeSRandomGen - case r of - Right sr -> do - putStrLn $ show sr - c <- client t sr h - handshake c - sendData c $ DBLC.pack $ encodeString "" - putStrLn ">>>>TLS data sended<<<<" - return (Just c) - Left ge -> do - putStrLn $ show ge - return Nothing - - --- TODO: Add logger - -xmlReader :: Chan InternalEvent -> [Event] -> Int -> - Iteratee Event IO (Maybe Event) - -xmlReader ch [EventBeginDocument] 0 = xmlReader ch [] 0 - --- TODO: Safe to start change level here? We are doing this since the stream can --- restart. --- TODO: l < 2? -xmlReader ch [EventBeginElement name attribs] l - | l < 3 && nameLocalName name == DT.pack "stream" && - namePrefix name == Just (DT.pack "stream") = do - liftIO $ writeChan ch $ IEX $ XEBeginStream $ defaultStream "TODO" - xmlReader ch [] 1 - -xmlReader ch [EventEndElement name] 1 - | namePrefix name == Just (DT.pack "stream") && - nameLocalName name == DT.pack "stream" = do - liftIO $ writeChan ch $ IEX XEEndStream - return Nothing - --- Check if counter is one to forward it to related function. --- Should replace "reverse ((EventEndElement n):es)" with es --- ... -xmlReader ch ((EventEndElement n):es) 1 - | nameLocalName n == DT.pack "proceed" = E.yield Nothing (E.Chunks []) - | otherwise = do - -- liftIO $ putStrLn "Got an IEX Event..." - liftIO $ writeChan ch $ IEX (processEventList (DL.reverse ((EventEndElement n):es))) - xmlReader ch [] 1 - --- Normal condition, buffer the event to events list. -xmlReader ch es co = do - head <- EL.head - let co' = counter co head - liftIO $ putStrLn $ show co' ++ "\t" ++ show head -- for test - case head of - Just e -> xmlReader ch (e:es) co' - Nothing -> xmlReader ch es co' - - --- TODO: Generate real event. -processEventList :: [Event] -> XMLEvent -processEventList e - | namePrefix name == Just (DT.pack "stream") && - nameLocalName name == DT.pack "features" = XEFeatures featuresDefault - | nameLocalName name == DT.pack "challenge" = - let EventContent (ContentText c) = head es in XEChallenge $ Chal $ DT.unpack c - | nameLocalName name == DT.pack "success" = - let EventContent (ContentText c) = head es in XESuccess $ Succ $ DT.unpack c - | nameLocalName name == DT.pack "iq" = XEIQ $ parseIQ $ eventsToElement e - | nameLocalName name == DT.pack "presence" = XEPresence $ parsePresence $ eventsToElement e - | nameLocalName name == DT.pack "message" = XEMessage $ parseMessage $ eventsToElement e - | otherwise = XEOther $ elementToString $ Just (eventsToElement e) - where - (EventBeginElement name attribs) = head e - es = tail e - -eventsToElement :: [Event] -> Element -eventsToElement e = do - documentRoot $ fromJust (run_ $ enum e $$ fromEvents) - where - enum :: [Event] -> E.Enumerator Event Maybe Document - enum e_ (E.Continue k) = k $ E.Chunks e_ - enum e_ step = E.returnI step - -counter :: Int -> Maybe Event -> Int -counter c (Just (EventBeginElement _ _)) = (c + 1) -counter c (Just (EventEndElement _) ) = (c - 1) -counter c _ = c - -presenceToXML :: Presence -> String -presenceToXML p = "" ++ - (elementsToString $ presencePayload p) ++ "" - where - s = presenceStanza p - - from :: String - from = case stanzaFrom $ presenceStanza p of - -- TODO: Lower-case - Just s -> " from='" ++ (jidToString s) ++ "'" - Nothing -> "" - - id' :: String - id' = case stanzaID s of - Just (SID s) -> " id='" ++ s ++ "'" - Nothing -> "" - - to :: String - to = case stanzaTo $ presenceStanza p of - -- TODO: Lower-case - Just s -> " to='" ++ (jidToString s) ++ "'" - Nothing -> "" - - type' :: String - type' = case presenceType p of - Available -> "" - t -> " type='" ++ (presenceTypeToString t) ++ "'" - -iqToXML :: IQ -> String -iqToXML IQGet { iqGetStanza = s, iqGetPayload = p } = - let type' = " type='get'" in "" ++ (elementToString (Just p)) ++ "" - where - from :: String - from = case stanzaFrom s of - -- TODO: Lower-case - Just s -> " from='" ++ (jidToString s) ++ "'" - Nothing -> "" - - id' :: String - id' = case stanzaID s of - Just (SID s) -> " id='" ++ s ++ "'" - Nothing -> "" - - to :: String - to = case stanzaTo s of - -- TODO: Lower-case - Just s -> " to='" ++ (jidToString s) ++ "'" - Nothing -> "" - -iqToXML IQSet { iqSetStanza = s, iqSetPayload = p } = - let type' = " type='set'" in "" ++ (elementToString (Just p)) ++ "" - where - from :: String - from = case stanzaFrom s of - -- TODO: Lower-case - Just s -> " from='" ++ (jidToString s) ++ "'" - Nothing -> "" - - id' :: String - id' = case stanzaID s of - Just (SID s) -> " id='" ++ s ++ "'" - Nothing -> "" - - to :: String - to = case stanzaTo s of - -- TODO: Lower-case - Just s -> " to='" ++ (jidToString s) ++ "'" - Nothing -> "" - -iqToXML IQResult { iqResultStanza = s, iqResultPayload = p } = - let type' = " type='result'" in "" ++ (elementToString p) ++ "" - where - from :: String - from = case stanzaFrom s of - -- TODO: Lower-case - Just s -> " from='" ++ (jidToString s) ++ "'" - Nothing -> "" - - id' :: String - id' = case stanzaID s of - Just (SID s) -> " id='" ++ s ++ "'" - Nothing -> "" - - to :: String - to = case stanzaTo s of - -- TODO: Lower-case - Just s -> " to='" ++ (jidToString s) ++ "'" - Nothing -> "" - -messageToXML :: Message -> String -messageToXML m = "" ++ - (elementsToString $ messagePayload m) ++ "" - where - s = messageStanza m - - from :: String - from = case stanzaFrom $ messageStanza m of - -- TODO: Lower-case - Just s -> " from='" ++ (jidToString s) ++ "'" - Nothing -> "" - - id' :: String - id' = case stanzaID s of - Just (SID s) -> " id='" ++ s ++ "'" - Nothing -> "" - - to :: String - to = case stanzaTo $ messageStanza m of - -- TODO: Lower-case - Just s -> " to='" ++ (jidToString s) ++ "'" - Nothing -> "" - - type' :: String - type' = case messageType m of - Normal -> "" - t -> " type='" ++ (messageTypeToString t) ++ "'" +{- + +Copyright © 2010-2011 Jon Kristensen. + +This file is part of Pontarius XMPP. + +Pontarius XMPP is free software: you can redistribute it and/or modify it under +the terms of the GNU Lesser General Public License as published by the Free +Software Foundation, either version 3 of the License, or (at your option) any +later version. + +Pontarius XMPP 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 Lesser General Public License for more +details. + +You should have received a copy of the GNU Lesser General Public License along +with Pontarius XMPP. If not, see . + +-} + +-- | Module: $Header$ +-- Description: XMPP client session management module +-- Copyright: Copyright © 2010-2011 Jon Kristensen +-- License: LGPL-3 +-- +-- Maintainer: info@pontarius.org +-- Stability: unstable +-- Portability: portable + + +-- I believe we need to use the MultiParamTypeClasses extension to be able to +-- work with arbitrary client states (solving the problem that the ClientState +-- type class is solving). However, I would be happy if someone proved me wrong. + +{-# LANGUAGE MultiParamTypeClasses #-} + +-- TODO: Better functions and events for stanzas, IncomingIQ, OutgoingIQ, etc. (ClientSession, ClientStanza) + +-- TODO: IO function to do everything related to the handle, instead of just connecting. + +-- TODO: Enumerate in the same thread? Enumerate one element at the time, non-blocking? + + +-- | This module provides the functions used by XMPP clients to manage their +-- XMPP sessions. +-- +-- Working with Pontarius XMPP is mostly done asynchronously with callbacks; +-- Pontarius XMPP "owns" the XMPP thread and carries the client state with it. +-- A client consists of a list of client handlers to handle XMPP events. This +-- is all set up through a @Session@ object, which a client can create by +-- calling the (blocking) function @createSession@. +-- +-- The Pontarius XMPP functions operate in an arbitrary MonadIO monad. +-- Typically, clients will use the IO monad. +-- +-- For more information, see the Pontarius XMPP Manual. + +module Network.XMPP.Session ( Certificate + , ClientHandler (..) + , ClientState (..) + , ConnectResult (..) + , HostName + , Password + , PortNumber + , Resource + , Session + , TerminationReason + , UserName + , OpenStreamResult (..) + , SecureWithTLSResult (..) + , AuthenticateResult (..) + , sendPresence + , sendIQ + , sendMessage + , connect + , openStream + , secureWithTLS + , authenticate + , createSession ) where + +import Network.XMPP.JID +import Network.XMPP.SASL +import Network.XMPP.Stanza +import Network.XMPP.Utilities + +import qualified Control.Exception as CE +import qualified Control.Exception.Base as CEB -- ? +import qualified Control.Monad.Error as CME +import qualified Control.Monad.State as CMS +import qualified Network as N + +------------- + +import Control.Concurrent.MVar + +import Codec.Binary.UTF8.String +import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) +import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay) +import Control.Monad.IO.Class (liftIO, MonadIO) +import Control.Monad.State hiding (State) +import Data.Enumerator (($$), Iteratee, continue, joinI, + run, run_, yield) +import Data.Enumerator.Binary (enumHandle, enumFile) +import Data.Maybe +import Data.String +import Data.XML.Types +import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput) +import Network.TLS +import Network.TLS.Cipher +import System.IO (BufferMode, BufferMode(NoBuffering)) +import Text.XML.Enumerator.Parse (parseBytes, decodeEntities) +import Text.XML.Enumerator.Document (fromEvents) +import qualified Codec.Binary.Base64.String as CBBS +import qualified Data.ByteString as DB +import qualified Data.ByteString.Lazy as DBL (ByteString, append, pack, fromChunks, toChunks, null) +import qualified Data.ByteString.Lazy.Char8 as DBLC (append, pack, unpack) +import qualified Data.Enumerator as E +import qualified Data.Enumerator.List as EL +import qualified Data.List as DL +import qualified Data.Text as DT +import qualified Data.Text.Lazy as DTL + + + +-- ============================================================================= +-- EXPORTED TYPES AND FUNCTIONS +-- ============================================================================= + + +-- | The @Session@ object is used by clients when interacting with Pontarius +-- XMPP. It holds information needed by Pontarius XMPP; its content is not +-- accessible from the client. + +data Session s m = Session { sessionChannel :: Chan (InternalEvent s m) } + + +-- | A client typically needs one or more @ClientHandler@ objects to interact +-- with Pontarius XMPP. Each client handler may provide four callback +-- functions; the first three callbacks deals with received stanzas, and the +-- last one is used when the session is terminated. +-- +-- These stanza functions takes the current client state and an object +-- containing the details of the stanza in question. The boolean returned +-- along with the possibly updated state signals whether or not the message +-- should be blocked to client handlerss further down the stack. For example, +-- an XEP-0030: Service Discovery handler may choose to hide disco\#info +-- requests to handlers above it in the stack. +-- +-- The 'sessionTerminated' callback function takes a 'TerminationReason' value +-- along with the state and will be sent to all client handlers. + +data MonadIO m => ClientHandler s m = + ClientHandler { messageReceived :: Maybe (Message -> StateT s m Bool) + , presenceReceived :: Maybe (Presence -> StateT s m Bool) + , iqReceived :: Maybe (IQ -> StateT s m Bool) + , sessionTerminated :: Maybe (TerminationReason -> + StateT s m ()) } + + +-- | Readability type for host name Strings. + +type HostName = String -- This is defined in Network as well + + +-- | Readability type for port number Integers. + +type PortNumber = Integer -- We use N(etwork).PortID (PortNumber) internally + + +-- | Readability type for user name Strings. + +type UserName = String + + +-- | Readability type for password Strings. + +type Password = String + + +-- | Readability type for (JID) resource identifier Strings. + +type Resource = String + + +-- | @TerminationReason@ contains information on why the XMPP session was +-- terminated. + +data TerminationReason = WhateverReason -- TODO + + +type Certificate = String -- TODO + +data ConnectResult = ConnectSuccess StreamProperties StreamFeatures (Maybe Resource) | + ConnectOpenStreamFailure | + ConnectSecureWithTLSFailure | + ConnectAuthenticateFailure + +data OpenStreamResult = OpenStreamSuccess StreamProperties StreamFeatures | + OpenStreamFailure + +data SecureWithTLSResult = SecureWithTLSSuccess StreamProperties StreamFeatures | SecureWithTLSFailure + +data AuthenticateResult = AuthenticateSuccess StreamProperties StreamFeatures Resource | AuthenticateFailure + +type StreamProperties = Float +type StreamFeatures = String + + +-- | Creates an XMPP session. Blocks the current thread. The first parameter, +-- @s@, is an arbitrary state that is defined by the client. This is the +-- initial state, and it will be passed to the client (handlers) as XMPP +-- events are emitted. The second parameter is the list of @ClientHandler@s; +-- this is a way to provide a "layered" system of XMPP event handlers. For +-- example, a client may have a dedicated handler to manage messages, +-- implement a spam protection system, etc. Messages are piped through these +-- handlers one by one, and any handler may block the message from being sent +-- to the next handler(s) above in the stack. The third argument is a callback +-- function that will be called when the session has been initialized, and +-- this function should be used by the client to store the Session object in +-- its state. + +-- Creates the internal event channel, injects the Pontarius XMPP session object +-- into the ClientState object, runs the "session created" client callback (in +-- the new state context), and stores the updated client state in s''. Finally, +-- we launch the (main) state loop of Pontarius XMPP. + +createSession :: (MonadIO m, ClientState s m) => s -> [ClientHandler s m] -> + (CMS.StateT s m ()) -> m () + +createSession s h c = do + threadID <- liftIO $ newEmptyMVar + chan <- liftIO $ newChan + ((), clientState) <- runStateT c (putSession s $ session chan) + (result, _) <- runStateT (stateLoop chan) + (defaultState chan threadID h clientState) + case result of + Just (CE.SomeException e) -> do + liftIO $ putStrLn "Got an exception!" + threadID' <- liftIO $ tryTakeMVar threadID + case threadID' of + Nothing -> do + liftIO $ putStrLn "No thread ID to kill" + Just t -> do + liftIO $ putStrLn "Killing thread" + liftIO $ killThread t + CE.throw e + Nothing -> + return () + where + -- session :: Chan (InternalEvent m s) -> Session m s -- TODO + session c = Session { sessionChannel = c } + + +defaultState :: (MonadIO m, ClientState s m) => Chan (InternalEvent s m) -> MVar ThreadId -> + [ClientHandler s m] -> s -> State s m + +defaultState c t h s = State { stateClientHandlers = h + , stateClientState = s + , stateChannel = c + , stateConnectionState = Disconnected + , stateStreamState = PreStream + , stateTLSState = NoTLS + , stateOpenStreamCallback = Nothing + , stateSecureWithTLSCallback = Nothing + , stateAuthenticateCallback = Nothing + , stateAuthenticationState = NoAuthentication + , stateResource = Nothing + , stateShouldExit = False + , stateThreadID = t + , stateIQCallbacks = [] } + + +connect :: MonadIO m => Session s m -> HostName -> PortNumber -> + Maybe (Certificate, (Certificate -> Bool)) -> + Maybe (UserName, Password, Maybe Resource) -> + (ConnectResult -> StateT s m ()) -> StateT s m () + +-- data ConnectResult = ConnectSuccess StreamProperties StreamFeatures Resource | +-- ConnectOpenStreamFailure | +-- ConnectTLSSecureStreamFailure | +-- ConnectAuthenticateFailure + +-- data OpenStreamResult = OpenStreamSuccess StreamProperties StreamFeatures | +-- OpenStreamFailure + +-- data SecureWithTLSResult = SecureWithTLSSuccess StreamProperties StreamFeatures | SecureWithTLSFailure + +-- data AuthenticateResult = AuthenticateSuccess Resource | AuthenticateFailure + + +connect s h p t a c = openStream s h p connect' + where + connect' r = case r of + OpenStreamSuccess _ _ -> case t of -- TODO: Check for TLS support? + Just (certificate, certificateValidator) -> + secureWithTLS s certificate certificateValidator connect'' + Nothing -> connect'' (SecureWithTLSSuccess 1.0 "") -- TODO + OpenStreamFailure -> c ConnectOpenStreamFailure + connect'' r = case r of + SecureWithTLSSuccess _ _ -> case a of + Just (userName, password, resource) -> + authenticate s userName password resource connect''' + Nothing -> connect''' (AuthenticateSuccess 1.0 "" "todo") -- TODO + SecureWithTLSFailure -> c ConnectSecureWithTLSFailure + connect''' r = case r of + AuthenticateSuccess streamProperties streamFeatures resource -> + c (ConnectSuccess streamProperties streamFeatures (Just resource)) + AuthenticateFailure -> c ConnectAuthenticateFailure + + +openStream :: MonadIO m => Session s m -> HostName -> PortNumber -> + (OpenStreamResult -> StateT s m ()) -> StateT s m () + +openStream s h p c = CMS.get >>= + (\ state -> lift $ liftIO $ writeChan (sessionChannel s) + (IEC (CEOpenStream state h p c))) + + +secureWithTLS :: MonadIO m => Session s m -> Certificate -> + (Certificate -> Bool) -> + (SecureWithTLSResult -> StateT s m ()) -> StateT s m () + +secureWithTLS s c a c_ = CMS.get >>= + (\ state -> lift $ liftIO $ + writeChan (sessionChannel s) + (IEC (CESecureWithTLS state c a c_))) + + +-- | + +authenticate :: MonadIO m => Session s m -> UserName -> Password -> + Maybe Resource -> (AuthenticateResult -> StateT s m ()) -> + StateT s m () + +authenticate s u p r c = CMS.get >>= + (\ state -> lift $ liftIO $ + writeChan (sessionChannel s) + (IEC (CEAuthenticate state u p r c))) + + +sendMessage :: MonadIO m => Session s m -> Message -> StateT s m () +sendMessage s m = CMS.get >>= + (\ state -> lift $ liftIO $ + writeChan (sessionChannel s) + (IEC (CEMessage state m))) + +sendPresence :: MonadIO m => Session s m -> Presence -> StateT s m () +sendPresence s p = CMS.get >>= + (\ state -> lift $ liftIO $ + writeChan (sessionChannel s) + (IEC (CEPresence state p))) + +sendIQ :: MonadIO m => Session s m -> IQ -> Maybe (IQ -> StateT s m Bool) -> StateT s m () +sendIQ s i c = CMS.get >>= + (\ state -> lift $ liftIO $ + writeChan (sessionChannel s) + (IEC (CEIQ state i c))) + +-- xmppDisconnect :: MonadIO m => Session s m -> Maybe (s -> (Bool, s)) -> m () +-- xmppDisconnect s c = xmppDisconnect s c + +class ClientState s m where + putSession :: s -> Session s m -> s + + +-- ============================================================================= +-- INTERNAL TYPES AND FUNCTIONS +-- ============================================================================= + + +data XMPPError = UncaughtEvent deriving (Eq, Show) + +instance CME.Error XMPPError where + strMsg "UncaughtEvent" = UncaughtEvent + +type StreamID = String + + +-- Client actions that needs to be performed in the (main) state loop are +-- converted to ClientEvents and sent through the internal event channel. + +data ClientEvent s m = CEOpenStream s N.HostName PortNumber + (OpenStreamResult -> StateT s m ()) | + CESecureWithTLS s Certificate (Certificate -> Bool) + (SecureWithTLSResult -> StateT s m ()) | + CEAuthenticate s UserName Password (Maybe Resource) + (AuthenticateResult -> StateT s m ()) | + CEMessage s Message | + CEPresence s Presence | + CEIQ s IQ (Maybe (IQ -> StateT s m Bool)) + +instance Show (ClientEvent s m) where + show (CEOpenStream _ h p _) = "CEOpenStream " ++ h ++ " " ++ (show p) + show (CESecureWithTLS _ c _ _) = "CESecureWithTLS " ++ c + show (CEAuthenticate _ u p r _) = "CEAuthenticate " ++ u ++ " " ++ p ++ " " ++ + (show r) + show (CEIQ _ i (Just _)) = "CEIQ " ++ (show i) ++ " (with callback)" + show (CEIQ _ i Nothing) = "CEIQ " ++ (show i) ++ " (without callback)" + show (CEMessage _ m) = "CEMessage " ++ (show m) + show (CEPresence _ p) = "CEPresence " ++ (show p) + + +-- An XMLEvent is triggered by an XML stanza or some other XML event, and is +-- sent through the internal event channel, just like client action events. + +data XMLEvent = XEBeginStream String | XEFeatures String | + XEChallenge Challenge | XESuccess Success | + XEEndStream | XEIQ IQ | XEPresence Presence | + XEMessage Message | XEProceed | + XEOther String deriving (Show) + + +-- instance Eq ConnectionState where +-- (==) Disconnected Disconnected = True +-- (==) ConnectedNotTLSSecured ConnectedNotTLSSecured = True +-- (==) (ConnectedTLSSecured _) (ConnectedTLSSecured _) = True +-- (==) _ _ = False + + +data EnumeratorEvent = EnumeratorDone | + EnumeratorXML XMLEvent | + EnumeratorException CE.SomeException + deriving (Show) + + +-- Type to contain the internal events. + +data InternalEvent s m = IEC (ClientEvent s m) | IEE EnumeratorEvent deriving (Show) + + +data Challenge = Chal String deriving (Show) + +data Success = Succ String deriving (Show) + + +data ConnectionState s m = Disconnected | Connected ServerAddress Handle + + +type OpenStreamCallback s m = Maybe (OpenStreamResult -> CMS.StateT s m ()) + +type SecureWithTLSCallback s m = Maybe (SecureWithTLSResult -> CMS.StateT s m ()) + +type AuthenticateCallback s m = Maybe (AuthenticateResult -> CMS.StateT s m ()) + + +data StreamState s m = PreStream | + PreFeatures StreamProperties | + PostFeatures StreamProperties StreamFeatures + + + +data TLSState = NoTLS | PreProceed | PreHandshake | PostHandshake TLSCtx + + +isTLSSecured :: TLSState -> Bool +isTLSSecured (PostHandshake _) = True +isTLSSecured _ = False + +data AuthenticationState s m = NoAuthentication | AuthenticatingPreChallenge1 String String (Maybe Resource) | AuthenticatingPreChallenge2 String String (Maybe Resource) | AuthenticatingPreSuccess String String (Maybe Resource) | AuthenticatedUnbound String (Maybe Resource) | AuthenticatedBound String Resource + + +isConnected :: ConnectionState s m -> Bool +isConnected Disconnected = True +isConnected (Connected _ _) = True + +instance Eq (ConnectionState s m) where + Disconnected == Disconnected = True + (Connected p h) == (Connected p_ h_) = p == p_ && h == h_ + -- (ConnectedPostFeatures s p h t) == (ConnectedPostFeatures s p h t) = True + -- (ConnectedAuthenticated s p h t) == (ConnectedAuthenticated s p h t) = True + _ == _ = False + +data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq) + +data MonadIO m => State s m = + State { stateClientHandlers :: [ClientHandler s m] + , stateClientState :: s + , stateChannel :: Chan (InternalEvent s m) + , stateConnectionState :: ConnectionState s m + , stateTLSState :: TLSState + , stateStreamState :: StreamState s m + , stateOpenStreamCallback :: OpenStreamCallback s m + , stateSecureWithTLSCallback :: SecureWithTLSCallback s m + , stateAuthenticateCallback :: AuthenticateCallback s m + , stateAuthenticationState :: AuthenticationState s m + , stateResource :: Maybe Resource + , stateShouldExit :: Bool + , stateThreadID :: MVar ThreadId + , stateIQCallbacks :: [(StanzaID, (IQ -> StateT s m Bool))] + } + + +-- Repeatedly reads internal events from the channel and processes them. This is +-- the main loop of the XMPP session process. + +-- The main loop of the XMPP library runs in the following monads: +-- +-- m, m => MonadIO (from the client) +-- StateT +-- ErrorT + +-- TODO: Will >> carry the updated state? +-- TODO: Should InternalState be in both places? + +stateLoop :: (MonadIO m, ClientState s m) => Chan (InternalEvent s m) -> + StateT (State s m) m (Maybe CE.SomeException) + +stateLoop c = do + event <- lift $ liftIO $ readChan c + lift $ liftIO $ putStrLn $ "Processing event " ++ (show event) ++ "." + result <- (processEvent event) + state <- get + case result of + Nothing -> do + case stateShouldExit state of + True -> + return $ Nothing + False -> + stateLoop c + Just e -> + return $ Just e + + +-- Process an InternalEvent and performs the necessary IO and updates the state +-- accordingly. + +processEvent :: (MonadIO m, ClientState s m) => (InternalEvent s m) -> + (StateT (State s m) m) (Maybe CE.SomeException) + +processEvent e = get >>= \ state -> + let handleOrTLSCtx = case stateTLSState state of + PostHandshake tlsCtx -> + Right tlsCtx + _ -> + let Connected _ handle = stateConnectionState state in Left handle + in case e of + + -- --------------------------------------------------------------------------- + -- CLIENT EVENTS + -- --------------------------------------------------------------------------- + -- + IEC (CEOpenStream clientState hostName portNumber callback) -> do + + CEB.assert (stateConnectionState state == Disconnected) (return ()) + + let portNumber' = fromIntegral portNumber + + connectResult <- liftIO $ CE.try $ N.connectTo hostName + (N.PortNumber portNumber') + + case connectResult of + Right handle -> do + put $ state { stateConnectionState = Connected (ServerAddress hostName portNumber') handle + , stateStreamState = PreStream + , stateOpenStreamCallback = Just callback } + lift $ liftIO $ hSetBuffering handle NoBuffering + lift $ liftIO $ send ("") (Left handle) + threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Left handle) + lift $ liftIO $ putMVar (stateThreadID state) threadID + return Nothing + Left e -> do + ((), clientState') <- lift $ runStateT (callback OpenStreamFailure) clientState + put $ state { stateShouldExit = True } + return $ Just e + + IEC (CESecureWithTLS clientState certificate verifyCertificate callback) -> do + -- CEB.assert (not $ isTLSSecured (stateStreamState state)) (return ()) + let Connected _ handle = stateConnectionState state + lift $ liftIO $ send "" (Left handle) + put $ state { stateStreamState = PreStream + , stateSecureWithTLSCallback = Just callback } + return Nothing + +-- TODO: Save callback in state. + IEC (CEAuthenticate clientState userName password resource callback) -> do + -- CEB.assert (or [ stateConnectionState state == Connected + -- , stateConnectionState state == TLSSecured ]) (return ()) + -- CEB.assert (stateHandle state /= Nothing) (return ()) + put $ state { stateAuthenticationState = AuthenticatingPreChallenge1 userName password resource + , stateAuthenticateCallback = Just callback } + lift $ liftIO $ send "" handleOrTLSCtx + return Nothing + + IEE (EnumeratorXML (XEBeginStream stream)) -> do + put $ state { stateStreamState = PreFeatures (1.0) } + return Nothing + + IEE (EnumeratorXML (XEFeatures features)) -> do + let PreFeatures streamProperties = stateStreamState state + case stateTLSState state of + NoTLS -> let callback = fromJust $ stateOpenStreamCallback state in do + ((), clientState) <- lift $ runStateT (callback $ OpenStreamSuccess streamProperties "TODO") (stateClientState state) + put $ state { stateClientState = clientState + , stateStreamState = PostFeatures streamProperties "TODO" } + return Nothing + _ -> case stateAuthenticationState state of + AuthenticatedUnbound _ resource -> do -- TODO: resource + case resource of + Nothing -> do + lift $ liftIO $ send ("") handleOrTLSCtx + return () + _ -> do + lift $ liftIO $ send ("" ++ fromJust resource ++ "") handleOrTLSCtx + return () + r <- lift $ liftIO $ getID + lift $ liftIO $ send ("" ++ "") handleOrTLSCtx + + -- TODO: Execute callback on iq result + + let callback = fromJust $ stateAuthenticateCallback state in do -- TODO: streamProperties "TODO" after success + ((), clientState) <- lift $ runStateT (callback $ AuthenticateSuccess streamProperties "TODO" "todo") (stateClientState state) -- get proper resource value when moving to iq result + put $ state { stateClientState = clientState + , stateStreamState = PostFeatures streamProperties "TODO" } + return Nothing + _ -> do + let callback = fromJust $ stateSecureWithTLSCallback state in do + ((), clientState) <- lift $ runStateT (callback $ SecureWithTLSSuccess streamProperties "TODO") (stateClientState state) + put $ state { stateClientState = clientState + , stateStreamState = PostFeatures streamProperties "TODO" } + return Nothing + + -- TODO: Can we assume that it's safe to start to enumerate on handle when it + -- might not have exited? + IEE (EnumeratorXML XEProceed) -> do + let Connected (ServerAddress hostName _) handle = stateConnectionState state + tlsCtx <- lift $ liftIO $ handshake' handle hostName + let tlsCtx_ = fromJust tlsCtx + put $ (defaultState (stateChannel state) (stateThreadID state) (stateClientHandlers state) (stateClientState state)) { stateTLSState = PostHandshake tlsCtx_, stateConnectionState = (stateConnectionState state), stateSecureWithTLSCallback = (stateSecureWithTLSCallback state) } + threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Right tlsCtx_) -- double code + lift $ liftIO $ putStrLn "00000000000000000000000000000000" + lift $ liftIO $ swapMVar (stateThreadID state) threadID -- return value not used + lift $ liftIO $ putStrLn "00000000000000000000000000000000" + lift $ liftIO $ threadDelay 1000000 + lift $ liftIO $ putStrLn "00000000000000000000000000000000" + lift $ liftIO $ send ("") (Right tlsCtx_) + lift $ liftIO $ putStrLn "00000000000000000000000000000000" + return Nothing + + IEE (EnumeratorXML (XEChallenge (Chal challenge))) -> do + let serverHost = "jonkristensen.com" + let challenge' = CBBS.decode challenge + case stateAuthenticationState state of + AuthenticatingPreChallenge1 userName password resource -> do + -- This is the first challenge - we need to calculate the reply + random <- lift $ liftIO $ getID -- TODO: Length and content. + case replyToChallenge1 challenge' serverHost userName password random of + Left reply -> do + let reply' = (filter (/= '\n') (CBBS.encode reply)) + lift $ liftIO $ send ("" ++ reply' ++ "") handleOrTLSCtx + put $ state { stateAuthenticationState = AuthenticatingPreChallenge2 userName password resource } + return () + Right error -> do + lift $ liftIO $ putStrLn $ show error + return () + AuthenticatingPreChallenge2 userName password resource -> do + -- This is not the first challenge; [...] + -- TODO: Can we assume "rspauth"? + lift $ liftIO $ send "" handleOrTLSCtx + put $ state { stateAuthenticationState = AuthenticatingPreSuccess userName password resource } + return () + return Nothing + + -- We have received a SASL "success" message over a secured connection + -- TODO: Parse the success message? + -- TODO: ? + IEE (EnumeratorXML (XESuccess (Succ _))) -> do + let serverHost = "jonkristensen.com" + let AuthenticatingPreSuccess userName _ resource = stateAuthenticationState state in do + lift $ liftIO $ send ("") handleOrTLSCtx + put $ state { stateAuthenticationState = AuthenticatedUnbound userName resource } + return Nothing + + IEE EnumeratorDone -> + -- TODO: Exit? + return Nothing + + -- --------------------------------------------------------------------------- + -- XML EVENTS + -- --------------------------------------------------------------------------- + + -- Ignore id="bind_1" and session IQ result, otherwise create client event + IEE (EnumeratorXML (XEIQ iqEvent)) -> do + case shouldIgnoreIQ iqEvent of + True -> + return Nothing + False -> do + let iqReceivedFunctions = map (\ x -> iqReceived x) (stateClientHandlers state) + let functions = map (\ x -> case x of + Just f -> Just (f iqEvent) + Nothing -> Nothing) iqReceivedFunctions + let functions' = case lookup (fromJust $ stanzaID $ iqStanza $ iqEvent) (stateIQCallbacks state) of + Just f -> (Just (f iqEvent)):functions + Nothing -> functions + let clientState = stateClientState state -- ClientState s m + clientState' <- sendToClient functions' clientState + put $ state { stateClientState = clientState' } + return Nothing + + IEE (EnumeratorXML (XEPresence presenceEvent)) -> do + let presenceReceivedFunctions = map (\ x -> presenceReceived x) (stateClientHandlers state) + let functions = map (\ x -> case x of + Just f -> Just (f presenceEvent) + Nothing -> Nothing) presenceReceivedFunctions + let clientState = stateClientState state -- ClientState s m + clientState' <- sendToClient functions clientState + put $ state { stateClientState = clientState' } + return Nothing + + IEE (EnumeratorXML (XEMessage messageEvent)) -> do + let messageReceivedFunctions = map (\ x -> messageReceived x) (stateClientHandlers state) + let functions = map (\ x -> case x of + Just f -> Just (f messageEvent) + Nothing -> Nothing) messageReceivedFunctions + let clientState = stateClientState state -- ClientState s m + clientState' <- sendToClient functions clientState + put $ state { stateClientState = clientState' } + return Nothing + + IEC (CEPresence clientState presence) -> do + presence' <- case stanzaID $ presenceStanza presence of + Nothing -> do + id <- lift $ liftIO $ getID + return $ presence { presenceStanza = (presenceStanza presence) { stanzaID = Just (SID id) } } + _ -> return presence + let xml = presenceToXML presence' + lift $ liftIO $ send xml handleOrTLSCtx + return Nothing + + IEC (CEMessage clientState message) -> do + message' <- case stanzaID $ messageStanza message of + Nothing -> do + id <- lift $ liftIO $ getID + return $ message { messageStanza = (messageStanza message) { stanzaID = Just (SID id) } } + _ -> return message + let xml = messageToXML message' + lift $ liftIO $ send xml handleOrTLSCtx + return Nothing + + IEC (CEIQ clientState iq callback) -> do + iq' <- case stanzaID $ iqStanza iq of + Nothing -> do + id <- lift $ liftIO $ getID + return $ case iq of + IQGet {} -> do + iq { iqGetStanza = (iqStanza iq) { stanzaID = Just (SID id) } } + IQSet {} -> do + iq { iqSetStanza = (iqStanza iq) { stanzaID = Just (SID id) } } + IQResult {} -> do + iq { iqResultStanza = (iqStanza iq) { stanzaID = Just (SID id) } } + _ -> return iq + case callback of + Just callback' -> case iq of + IQGet {} -> put $ state { stateIQCallbacks = (fromJust $ stanzaID $ iqStanza iq', callback'):(stateIQCallbacks state) } + IQSet {} -> put $ state { stateIQCallbacks = (fromJust $ stanzaID $ iqStanza iq', callback'):(stateIQCallbacks state) } + _ -> return () + Nothing -> return () + -- TODO: Bind ID to callback + let xml = iqToXML iq' + lift $ liftIO $ send xml handleOrTLSCtx + return Nothing + + -- XOEDisconnect -> do + -- -- TODO: Close stream + -- return () + + e -> do + return Nothing + -- lift $ liftIO $ putStrLn $ "UNCAUGHT EVENT: " ++ (show e) + -- return $ Just (CE.SomeException $ CE.PatternMatchFail "processEvent") + where + -- Assumes handle is set + send :: String -> Either Handle TLSCtx -> IO () + send s o = case o of + Left handle -> do + liftIO $ hPutStr handle $ encodeString $ s + liftIO $ hFlush handle + return () + Right tlsCtx -> do + liftIO $ sendData tlsCtx $ DBLC.pack $ encodeString s + return () + shouldIgnoreIQ :: IQ -> Bool + shouldIgnoreIQ i = case iqPayload i of + Nothing -> False + Just e -> case nameNamespace $ elementName e of + Just x | x == DT.pack "urn:ietf:params:xml:ns:xmpp-bind" -> True + Just x | x == DT.pack "urn:ietf:params:xml:ns:xmpp-session" -> True + Just _ -> False + Nothing -> False + + +sendToClient :: (MonadIO m, ClientState s m) => [Maybe (StateT s m Bool)] -> s -> (StateT (State s m) m) s +sendToClient [] s = return s +sendToClient (Nothing:fs) s = sendToClient fs s +sendToClient ((Just f):fs) s = do + (b, s') <- lift $ runStateT f s + case b of + True -> return s' + False -> sendToClient fs s' + + +-- Reads from the provided handle or TLS context and sends the events to the +-- internal event channel. + +xmlEnumerator :: Chan (InternalEvent s m) -> Either Handle TLSCtx -> IO () +xmlEnumerator c s = do + enumeratorResult <- case s of + Left handle -> run $ enumHandle 1 handle $$ joinI $ + parseBytes decodeEntities $$ xmlReader c + Right tlsCtx -> run $ enumTLS tlsCtx $$ joinI $ + parseBytes decodeEntities $$ xmlReader c + case enumeratorResult of + Right _ -> + writeChan c $ IEE EnumeratorDone + Left e -> + writeChan c $ IEE (EnumeratorException e) + where + -- Behaves like enumHandle, but reads from the TLS context instead + enumTLS :: TLSCtx -> E.Enumerator DB.ByteString IO b + enumTLS c s = loop c s + + loop :: TLSCtx -> E.Step DB.ByteString IO b -> E.Iteratee DB.ByteString IO b + loop c (E.Continue k) = do + d <- recvData c + case DBL.null d of + True -> loop c (E.Continue k) + False -> k (E.Chunks $ DBL.toChunks d) E.>>== loop c + loop _ step = E.returnI step + + +getTLSParams :: TLSParams +getTLSParams = TLSParams { pConnectVersion = TLS10 + , pAllowedVersions = [TLS10,TLS11] + , pCiphers = [cipher_AES256_SHA1] -- Check the rest + , pCompressions = [nullCompression] + , pWantClientCert = False + , pCertificates = [] + , onCertificatesRecv = \_ -> return True } -- Verify cert chain + +handshake' :: Handle -> String -> IO (Maybe TLSCtx) +handshake' h s = do + let t = getTLSParams + r <- makeSRandomGen + case r of + Right sr -> do + putStrLn $ show sr + c <- client t sr h + handshake c + putStrLn ">>>>TLS data sended<<<<" + return (Just c) + Left ge -> do + putStrLn $ show ge + return Nothing + + +xmlReader :: Chan (InternalEvent s m) -> Iteratee Event IO (Maybe Event) + +xmlReader c = xmlReader_ c [] 0 + + +xmlReader_ :: Chan (InternalEvent s m) -> [Event] -> Int -> + Iteratee Event IO (Maybe Event) + +xmlReader_ ch [EventBeginDocument] 0 = xmlReader_ ch [] 0 + +-- TODO: Safe to start change level here? We are doing this since the stream can +-- restart. +-- TODO: l < 2? +xmlReader_ ch [EventBeginElement name attribs] l + | l < 3 && nameLocalName name == DT.pack "stream" && + namePrefix name == Just (DT.pack "stream") = do + liftIO $ writeChan ch $ IEE $ EnumeratorXML $ XEBeginStream $ "StreamTODO" + xmlReader_ ch [] 1 + +xmlReader_ ch [EventEndElement name] 1 + | namePrefix name == Just (DT.pack "stream") && + nameLocalName name == DT.pack "stream" = do + liftIO $ writeChan ch $ IEE $ EnumeratorXML $ XEEndStream + return Nothing + +-- Check if counter is one to forward it to related function. +-- Should replace "reverse ((EventEndElement n):es)" with es +-- ... +xmlReader_ ch ((EventEndElement n):es) 1 + | nameLocalName n == DT.pack "proceed" = do + liftIO $ writeChan ch $ IEE $ EnumeratorXML $ XEProceed + E.yield Nothing (E.Chunks []) + | otherwise = do + -- liftIO $ putStrLn "Got an IEX Event..." + liftIO $ writeChan ch $ IEE $ EnumeratorXML $ (processEventList (DL.reverse ((EventEndElement n):es))) + xmlReader_ ch [] 1 + +-- Normal condition, buffer the event to events list. +xmlReader_ ch es co = do + head <- EL.head + let co' = counter co head + -- liftIO $ putStrLn $ show co' ++ "\t" ++ show head -- for test + case head of + Just e -> xmlReader_ ch (e:es) co' + Nothing -> xmlReader_ ch es co' + + +-- TODO: Generate real event. +processEventList :: [Event] -> XMLEvent +processEventList e + | namePrefix name == Just (DT.pack "stream") && + nameLocalName name == DT.pack "features" = XEFeatures "FeaturesTODO" + | nameLocalName name == DT.pack "challenge" = + let EventContent (ContentText c) = head es in XEChallenge $ Chal $ DT.unpack c + | nameLocalName name == DT.pack "success" = + let EventContent (ContentText c) = head es in XESuccess $ Succ $ "" -- DT.unpack c + | nameLocalName name == DT.pack "iq" = XEIQ $ parseIQ $ eventsToElement e + | nameLocalName name == DT.pack "presence" = XEPresence $ parsePresence $ eventsToElement e + | nameLocalName name == DT.pack "message" = XEMessage $ parseMessage $ eventsToElement e + | otherwise = XEOther $ elementToString $ Just (eventsToElement e) + where + (EventBeginElement name attribs) = head e + es = tail e + +eventsToElement :: [Event] -> Element +eventsToElement e = do + documentRoot $ fromJust (run_ $ enum e $$ fromEvents) + where + enum :: [Event] -> E.Enumerator Event Maybe Document + enum e_ (E.Continue k) = k $ E.Chunks e_ + enum e_ step = E.returnI step + +counter :: Int -> Maybe Event -> Int +counter c (Just (EventBeginElement _ _)) = (c + 1) +counter c (Just (EventEndElement _) ) = (c - 1) +counter c _ = c + +presenceToXML :: Presence -> String +presenceToXML p = "" ++ + (elementsToString $ presencePayload p) ++ "" + where + s = presenceStanza p + + from :: String + from = case stanzaFrom $ presenceStanza p of + -- TODO: Lower-case + Just s -> " from='" ++ (jidToString s) ++ "'" + Nothing -> "" + + id' :: String + id' = case stanzaID s of + Just (SID s) -> " id='" ++ s ++ "'" + Nothing -> "" + + to :: String + to = case stanzaTo $ presenceStanza p of + -- TODO: Lower-case + Just s -> " to='" ++ (jidToString s) ++ "'" + Nothing -> "" + + type' :: String + type' = case presenceType p of + Available -> "" + t -> " type='" ++ (presenceTypeToString t) ++ "'" + +iqToXML :: IQ -> String +iqToXML IQGet { iqGetStanza = s, iqGetPayload = p } = + let type' = " type='get'" in "" ++ (elementToString (Just p)) ++ "" + where + from :: String + from = case stanzaFrom s of + -- TODO: Lower-case + Just s -> " from='" ++ (jidToString s) ++ "'" + Nothing -> "" + + id' :: String + id' = case stanzaID s of + Just (SID s) -> " id='" ++ s ++ "'" + Nothing -> "" + + to :: String + to = case stanzaTo s of + -- TODO: Lower-case + Just s -> " to='" ++ (jidToString s) ++ "'" + Nothing -> "" + +iqToXML IQSet { iqSetStanza = s, iqSetPayload = p } = + let type' = " type='set'" in "" ++ (elementToString (Just p)) ++ "" + where + from :: String + from = case stanzaFrom s of + -- TODO: Lower-case + Just s -> " from='" ++ (jidToString s) ++ "'" + Nothing -> "" + + id' :: String + id' = case stanzaID s of + Just (SID s) -> " id='" ++ s ++ "'" + Nothing -> "" + + to :: String + to = case stanzaTo s of + -- TODO: Lower-case + Just s -> " to='" ++ (jidToString s) ++ "'" + Nothing -> "" + +iqToXML IQResult { iqResultStanza = s, iqResultPayload = p } = + let type' = " type='result'" in "" ++ (elementToString p) ++ "" + where + from :: String + from = case stanzaFrom s of + -- TODO: Lower-case + Just s -> " from='" ++ (jidToString s) ++ "'" + Nothing -> "" + + id' :: String + id' = case stanzaID s of + Just (SID s) -> " id='" ++ s ++ "'" + Nothing -> "" + + to :: String + to = case stanzaTo s of + -- TODO: Lower-case + Just s -> " to='" ++ (jidToString s) ++ "'" + Nothing -> "" + +messageToXML :: Message -> String +messageToXML m = "" ++ + (elementsToString $ messagePayload m) ++ "" + where + s = messageStanza m + + from :: String + from = case stanzaFrom $ messageStanza m of + -- TODO: Lower-case + Just s -> " from='" ++ (jidToString s) ++ "'" + Nothing -> "" + + id' :: String + id' = case stanzaID s of + Just (SID s) -> " id='" ++ s ++ "'" + Nothing -> "" + + to :: String + to = case stanzaTo $ messageStanza m of + -- TODO: Lower-case + Just s -> " to='" ++ (jidToString s) ++ "'" + Nothing -> "" + + type' :: String + type' = case messageType m of + Normal -> "" + t -> " type='" ++ (messageTypeToString t) ++ "'" + + +parseIQ :: Element -> IQ +parseIQ e | typeAttr == "get" = let (Just payloadMust) = payload + in iqGet idAttr fromAttr toAttr Nothing + payloadMust + | typeAttr == "set" = let (Just payloadMust) = payload + in iqSet idAttr fromAttr toAttr Nothing + payloadMust + | typeAttr == "result" = iqResult idAttr fromAttr toAttr Nothing + payload + + where + -- TODO: Many duplicate functions from parsePresence. + + payload :: Maybe Element + payload = case null (elementChildren e) of + True -> Nothing + False -> Just $ head $ elementChildren e + + typeAttr :: String + typeAttr = case attributeText typeName e of + -- Nothing -> Nothing + Just a -> DT.unpack a + + fromAttr :: Maybe JID + fromAttr = case attributeText fromName e of + Nothing -> Nothing + Just a -> stringToJID $ DT.unpack a + + toAttr :: Maybe JID + toAttr = case attributeText toName e of + Nothing -> Nothing + Just a -> stringToJID $ DT.unpack a + + idAttr :: Maybe StanzaID + idAttr = case attributeText idName e of + Nothing -> Nothing + Just a -> Just (SID (DT.unpack a)) + + typeName :: Name + typeName = fromString "type" + + fromName :: Name + fromName = fromString "from" + + toName :: Name + toName = fromString "to" + + idName :: Name + idName = fromString "id" + +-- TODO: Parse xml:lang + +parsePresence :: Element -> Presence +parsePresence e = presence idAttr fromAttr toAttr Nothing typeAttr (elementChildren e) + where + -- TODO: Many duplicate functions from parseIQ. + + typeAttr :: PresenceType + typeAttr = case attributeText typeName e of + Just t -> stringToPresenceType $ DT.unpack t + Nothing -> Available + + fromAttr :: Maybe JID + fromAttr = case attributeText fromName e of + Nothing -> Nothing + Just a -> stringToJID $ DT.unpack a + + toAttr :: Maybe JID + toAttr = case attributeText toName e of + Nothing -> Nothing + Just a -> stringToJID $ DT.unpack a + + idAttr :: Maybe StanzaID + idAttr = case attributeText idName e of + Nothing -> Nothing + Just a -> Just (SID (DT.unpack a)) + + fromName :: Name + fromName = fromString "from" + + typeName :: Name + typeName = fromString "type" + + toName :: Name + toName = fromString "to" + + idName :: Name + idName = fromString "id" + +parseMessage :: Element -> Message +parseMessage e = message idAttr fromAttr toAttr Nothing typeAttr (elementChildren e) + where + -- TODO: Many duplicate functions from parseIQ. + + typeAttr :: MessageType + typeAttr = case attributeText typeName e of + Just t -> stringToMessageType $ DT.unpack t + Nothing -> Normal + + fromAttr :: Maybe JID + fromAttr = case attributeText fromName e of + Nothing -> Nothing + Just a -> stringToJID $ DT.unpack a + + toAttr :: Maybe JID + toAttr = case attributeText toName e of + Nothing -> Nothing + Just a -> stringToJID $ DT.unpack a + + idAttr :: Maybe StanzaID + idAttr = case attributeText idName e of + Nothing -> Nothing + Just a -> Just (SID (DT.unpack a)) + + fromName :: Name + fromName = fromString "from" + + typeName :: Name + typeName = fromString "type" + + toName :: Name + toName = fromString "to" + + idName :: Name + idName = fromString "id" + +-- stringToPresenceType "available" = Available +-- stringToPresenceType "away" = Away +-- stringToPresenceType "chat" = Chat +-- stringToPresenceType "dnd" = DoNotDisturb +-- stringToPresenceType "xa" = ExtendedAway + +stringToPresenceType "probe" = Probe +stringToPresenceType "error" = PresenceError + +stringToPresenceType "unavailable" = Unavailable +stringToPresenceType "subscribe" = Subscribe +stringToPresenceType "subscribed" = Subscribed +stringToPresenceType "unsubscribe" = Unsubscribe +stringToPresenceType "unsubscribed" = Unsubscribed + +-- presenceTypeToString Available = "available" + +-- presenceTypeToString Away = "away" +-- presenceTypeToString Chat = "chat" +-- presenceTypeToString DoNotDisturb = "dnd" +-- presenceTypeToString ExtendedAway = "xa" + +presenceTypeToString Unavailable = "unavailable" + +presenceTypeToString Probe = "probe" +presenceTypeToString PresenceError = "error" + +presenceTypeToString Subscribe = "subscribe" +presenceTypeToString Subscribed = "subscribed" +presenceTypeToString Unsubscribe = "unsubscribe" +presenceTypeToString Unsubscribed = "unsubscribed" + +stringToMessageType "chat" = Chat +stringToMessageType "error" = MessageError +stringToMessageType "groupchat" = Groupchat +stringToMessageType "headline" = Headline +stringToMessageType "normal" = Normal +stringToMessageType s = OtherMessageType s + +messageTypeToString Chat = "chat" +messageTypeToString MessageError = "error" +messageTypeToString Groupchat = "groupchat" +messageTypeToString Headline = "headline" +messageTypeToString Normal = "normal" +messageTypeToString (OtherMessageType s) = s diff --git a/Network/XMPP/Stanza.hs b/Network/XMPP/Stanza.hs --- a/Network/XMPP/Stanza.hs +++ b/Network/XMPP/Stanza.hs @@ -1,7 +1,28 @@ +{- + +Copyright © 2010-2011 Jon Kristensen. + +This file is part of Pontarius XMPP. + +Pontarius XMPP is free software: you can redistribute it and/or modify it under +the terms of the GNU Lesser General Public License as published by the Free +Software Foundation, either version 3 of the License, or (at your option) any +later version. + +Pontarius XMPP 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 Lesser General Public License for more +details. + +You should have received a copy of the GNU Lesser General Public License along +with Pontarius XMPP. If not, see . + +-} + -- | Module: $Header$ -- Description: XMPP stanza types and utility functions -- Copyright: Copyright © 2010-2011 Jon Kristensen --- License: BSD-3 +-- License: LGPL-3 -- -- Maintainer: info@pontarius.org -- Stability: unstable @@ -25,10 +46,12 @@ , Presence (..) , presence , IQ (..) + , getId -- Just return the Id of existing IQ , iqGet , iqSet , iqResult , iqStanza + , iqAck , iqPayloadNamespace , iqPayload ) where @@ -36,7 +59,7 @@ import Data.XML.Types import qualified Data.Text as DT - +import Data.Maybe (fromJust) data StanzaID = SID String deriving (Eq, Show) type From = JID @@ -150,6 +173,8 @@ , stanzaLang = l } , iqResultPayload = p } +iqAck :: StanzaID -> To -> IQ +iqAck s t = iqResult (Just s) Nothing (Just t) Nothing Nothing iqStanza :: IQ -> Stanza iqStanza (IQGet { iqGetStanza = s }) = s @@ -168,6 +193,9 @@ Nothing -> Nothing Just n -> Just (DT.unpack n) +-- Get the id from existing IQ +getId :: IQ -> StanzaID +getId iq = fromJust $ stanzaID $ iqStanza iq -- ============================================================================= -- CODE NOT YET USED diff --git a/Network/XMPP/Utilities.hs b/Network/XMPP/Utilities.hs --- a/Network/XMPP/Utilities.hs +++ b/Network/XMPP/Utilities.hs @@ -1,8 +1,29 @@ +{- + +Copyright © 2010-2011 Jon Kristensen. + +This file is part of Pontarius XMPP. + +Pontarius XMPP is free software: you can redistribute it and/or modify it under +the terms of the GNU Lesser General Public License as published by the Free +Software Foundation, either version 3 of the License, or (at your option) any +later version. + +Pontarius XMPP 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 Lesser General Public License for more +details. + +You should have received a copy of the GNU Lesser General Public License along +with Pontarius XMPP. If not, see . + +-} + -- | Module: $Header$ -- Description: Utility functions for Pontarius XMPP; currently only random ID -- generation functions -- Copyright: Copyright © 2010-2011 Jon Kristensen --- License: BSD-3 +-- License: LGPL-3 -- -- Maintainer: info@pontarius.org -- Stability: unstable @@ -77,7 +98,7 @@ elementToString :: Maybe Element -> String elementToString Nothing = "" elementToString (Just e) = "<" ++ nameToString (elementName e) ++ xmlns ++ - attributes (DM.toList (elementAttributes e)) ++ + attributes (elementAttributes e) ++ ">" ++ (nodesToString $ elementNodes e) ++ "" where diff --git a/README b/README --- a/README +++ b/README @@ -1,5 +1,5 @@ Pontarius XMPP aims to be a secure and easy-to-use XMPP library for Haskell. We -have just released a third alpha version with the following features: +have just released a fourth alpha version with the following features: * Client-to-server Transport Layer Security and DIGEST-MD5 SASL Authentication * Concurrent, Flexible and Event-based API for XMPP Client Developers @@ -12,12 +12,11 @@ to contact the Pontarius project and we will try to help you get started. You can also see the Example directory for a usage example. -We are currently working on general improvements, securing the client-to-client -communication and having the library support all of RFC 3920: XMPP Core. +We are currently working on general improvements and having the library support +all of RFC 3920: XMPP Core. -We will release the next version, 0.1 Alpha 4, on the 4th of May. +The next version, 0.1 Alpha 5, is scheduled to be released on the 15th of June. -Look at the Pontarius web site , the Pontarius XMPP -web page and the Pontarius +Look at the Pontarius web site and the Pontarius XMPP Hackage page for more information. diff --git a/XTLS.hs b/XTLS.hs deleted file mode 100644 --- a/XTLS.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - - -module XTLS (start) where - -import Network.XMPP -import Control.Concurrent (forkIO) -import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) - -import Data.XML.Types -import Network.XMPP.Stanza -import Control.Monad ((>=>)) -import Data.Maybe - -data State = State {} - -start :: IO () -start = putStrLn "Test" - -stateLoop :: State -> Chan XMPPInEvent -> Chan XMPPOutEvent -> IO () -stateLoop s c c_ = do - e <- readChan c - s' <- processEvent e s c_ - stateLoop s' c c_ - -processEvent :: XMPPInEvent -> State -> Chan XMPPOutEvent -> IO State --- processEvent (PATTERN_MATCHING) s c = do --- return s -processEvent (XIEIQ iq) s c = do - -- putStrLn - case xtlsOrJingle iq of - 'j' -> return s - 'x' -> return s - 'n' -> return s - -xtlsOrJingle :: IQ -> Char -xtlsOrJingle iq = - case iqPayloadNamespace iq of - Just "urn:xmpp:jingle:1" -> - case isXTLS $ head $ getContent (fromJust $ iqPayload iq) of - [] -> 'j' - other -> 'x' - other -> 'n' - where - isXTLS :: Element -> [Element] - isXTLS = elementChildren >=> isNamed xtlsName - - getContent :: Element -> [Element] - getContent = elementChildren >=> isNamed "content" - - -xtlsName :: Name -xtlsName = ( "{urn:xmpp:jingle:security:xtls:0}security" :: Name ) - --- Jingle Event base on the XEP-166 -data JingleEvent = ContentAccept | ContentAdd | ContentModify | ContentReject | - ContentRemove | DiscriptionInfo | TransportAccept | - TransportInfo | TransportReject | TransportReplace - -data JingleSession = Initiated { sid :: String , candidate :: [Candidate] } | - Accepted { sid :: String , candidate :: [Candidate] } | - Media { sid :: String } | - Terminated { sid :: String } - -data Candidate = Candidate { id :: Int , - ip :: String , - portNum :: Int , - priority :: Int } - -data Transport = IBB { transid :: String , blockSize :: Int} | - OBB { transid :: String } -- TODO : define the OBB - - -data XTLSSecurity = XTLSSecurity { fingerPrint :: String , methods :: [MethodName]} -data MethodName = SRP | X509 diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -2,18 +2,18 @@ -- TODO: Highlighting bug: The last line of the description. Name: pontarius-xmpp -Version: 0.0.3.0 +Version: 0.0.4.0 Cabal-Version: >= 1.6 Build-Type: Simple -License: BSD3 +License: LGPL-3 License-File: LICENSE Copyright: Copyright © 2011, Jon Kristensen Author: Jon Kristensen, Mahdi Abdinejadi Maintainer: jon.kristensen@pontarius.org Stability: alpha -Homepage: http://www.pontarius.org/projects/pontarius-xmpp/ +Homepage: http://www.pontarius.org/ Bug-Reports: mailto:info@pontarius.org -Package-URL: http://www.pontarius.org/releases/pontarius-xmpp-0.0.3.0.tar.gz +Package-URL: http://www.pontarius.org/releases/pontarius-xmpp-0.0.4.0.tar.gz Synopsis: A (prototyped) secure and easy to use XMPP library Description: A work in progress of an implementation of RFC 3920: XMPP Core. @@ -29,11 +29,10 @@ Network.XMPP.Session, Network.XMPP.Stanza, Network.XMPP.Utilities Exposed: True - Build-Depends: hlogger ==0.0.3.0, base >= 2 && < 5, enumerator, - crypto-api, base64-string, regex-posix, pureMD5, - utf8-string, network, xml-types, text, transformers, - bytestring, binary, random, xml-enumerator, tls ==0.4.1, - containers + Build-Depends: base >= 2 && < 5, enumerator, crypto-api, base64-string, + regex-posix, pureMD5, utf8-string, network, xml-types, + text, transformers, bytestring, binary, random, + xml-enumerator, tls ==0.4.1, containers -- Other-Modules: -- HS-Source-Dirs: -- Extensions: @@ -91,5 +90,5 @@ Type: darcs -- Module: Location: https://patch-tag.com/r/jonkri/pontarius-xmpp - Tag: 0.0.3.0 + Tag: 0.0.4.0 -- Subdir: