initial import, copy of darcs repository

COPYING

@@ -0,0 +1,674 @@
+                    GNU GENERAL PUBLIC LICENSE
+                       Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+                            Preamble
+
+  The GNU 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.
+
+    <one line to give the program's name and a brief idea of what it does.>
+    Copyright (C) <year>  <name of author>
+
+    This program is free software: you can redistribute it and/or modify
+    it under the terms of the GNU 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 <http://www.gnu.org/licenses/>.
+
+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:
+
+    <program>  Copyright (C) <year>  <name of author>
+    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
+<http://www.gnu.org/licenses/>.
+
+  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
+<http://www.gnu.org/philosophy/why-not-lgpl.html>.

COPYING.LESSER

@@ -0,0 +1,165 @@
+                   GNU LESSER GENERAL PUBLIC LICENSE
+                       Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+
+  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.

Documentation/Pontarius XMPP Manual.lyx

@@ -0,0 +1,536 @@
+#LyX 2.0 created this file. For more info see http://www.lyx.org/
+\lyxformat 413
+\begin_document
+\begin_header
+\textclass article
+\use_default_options true
+\maintain_unincluded_children false
+\language english
+\language_package default
+\inputencoding auto
+\fontencoding global
+\font_roman default
+\font_sans default
+\font_typewriter default
+\font_default_family default
+\use_non_tex_fonts false
+\font_sc false
+\font_osf false
+\font_sf_scale 100
+\font_tt_scale 100
+
+\graphics default
+\default_output_format default
+\output_sync 0
+\bibtex_command default
+\index_command default
+\paperfontsize default
+\spacing single
+\use_hyperref false
+\papersize default
+\use_geometry false
+\use_amsmath 1
+\use_esint 1
+\use_mhchem 1
+\use_mathdots 1
+\cite_engine basic
+\use_bibtopic false
+\use_indices false
+\paperorientation portrait
+\suppress_date false
+\use_refstyle 1
+\index Index
+\shortcut idx
+\color #008000
+\end_index
+\secnumdepth 3
+\tocdepth 3
+\paragraph_separation indent
+\paragraph_indentation default
+\quotes_language english
+\papercolumns 1
+\papersides 1
+\paperpagestyle default
+\tracking_changes false
+\output_changes false
+\html_math_output 0
+\html_css_as_file 0
+\html_be_strict false
+\end_header
+
+\begin_body
+
+\begin_layout Title
+Pontarius XMPP 0.1 Manual (Third Draft)
+\end_layout
+
+\begin_layout Author
+The Pontarius Project
+\end_layout
+
+\begin_layout Date
+The 6th of July, 2011
+\end_layout
+
+\begin_layout Standard
+\begin_inset CommandInset toc
+LatexCommand tableofcontents
+
+\end_inset
+
+
+\end_layout
+
+\begin_layout Section
+Introduction
+\end_layout
+
+\begin_layout Standard
+Pontarius XMPP aims to be a convenient-to-use, powerful, correct, secure,
+ and extendable XMPP client library for Haskell.
+ It is written by Jon Kristensen and Mahdi Abdinejadi.
+ Being licensed under the GNU Lesser General Public License, Pontarius XMPP
+ is free and open source software.
+\end_layout
+
+\begin_layout Section
+Features and Implementation Specifics
+\end_layout
+
+\begin_layout Standard
+Pontarius XMPP 0.1 implements the client capabilities of the XMPP Core specificat
+ion (RFC 6120)
+\begin_inset Foot
+status open
+
+\begin_layout Plain Layout
+http://tools.ietf.org/html/rfc6120
+\end_layout
+
+\end_inset
+
+.
+ Below are the specifics of our implementation.
+\end_layout
+
+\begin_layout Itemize
+The client is always the initiating entity
+\end_layout
+
+\begin_layout Itemize
+A client-of-server connection is always exactly one TCP connection
+\end_layout
+
+\begin_layout Itemize
+TLS is supported for client-to-server confidentiality
+\end_layout
+
+\begin_layout Itemize
+Only the SCRAM authentication method is supported
+\end_layout
+
+\begin_layout Itemize
+...
+\end_layout
+
+\begin_layout Standard
+Later versions will add supports for different XMPP extensions, such as
+ RFC 6121 (XMPP IM), XEP-0004: Data Forms, and XEP-0077: In-Band Registration.
+\begin_inset Foot
+status open
+
+\begin_layout Plain Layout
+XMPP RFCs can be found at http://xmpp.org/xmpp-protocols/rfcs/, and the so-called
+ XEPs at http://xmpp.org/xmpp-protocols/xmpp-extensions/.
+\end_layout
+
+\end_inset
+
+
+\end_layout
+
+\begin_layout Section
+Usage
+\end_layout
+
+\begin_layout Standard
+Working with Pontarius XMPP is mostly done asynchronously; Pontarius XMPP
+ ``owns'' the XMPP thread, and calls different StateT s m a callback functions
+ in the client.
+ StateT is a monad transformer which allows the functions to be stateful
+ (being able to access and modify the arbitrary client-defined state of
+ type s) and to be executed on top of a MonadIO m monad (typically IO).
+\end_layout
+
+\begin_layout Subsection
+Creating the session
+\end_layout
+
+\begin_layout Standard
+Setting up an XMPP session is done through the (blocking) session function:
+\end_layout
+
+\begin_layout Standard
+\begin_inset listings
+inline false
+status open
+
+\begin_layout Plain Layout
+
+session :: (MonadIO m, ClientState s m) => s ->
+\end_layout
+
+\begin_layout Plain Layout
+
+	[ClientHandler s m] -> (StateT s m ()) -> m ()
+\end_layout
+
+\end_inset
+
+
+\end_layout
+
+\begin_layout Standard
+The first parameter (of type s) is an arbitrary state that is defined by
+ the client.
+ This is the initial state, and it will be passed to the stateful client
+ callbacks.
+ It will typically be modified by the client.
+\end_layout
+
+\begin_layout Standard
+The second parameter is the list of client handlers to deal with XMPP callbacks.
+ The reason why we have a list is because we want to provide a ``layered''
+ system of XMPP event handlers.
+ For example, XMPP client developers may want to have a dedicated handler
+ to manage messages, implement a spam protection system, and so on.
+ 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.
+\end_layout
+
+\begin_layout Standard
+\begin_inset listings
+inline false
+status open
+
+\begin_layout Plain Layout
+
+data MonadIO m => ClientHandler s m = ClientHandler {
+\end_layout
+
+\begin_layout Plain Layout
+
+	messageReceived :: Maybe (Message ->
+\end_layout
+
+\begin_layout Plain Layout
+
+	StateT s m Bool), presenceReceived :: Maybe
+\end_layout
+
+\begin_layout Plain Layout
+
+	(Presence -> StateT s m Bool), iqReceived ::
+\end_layout
+
+\begin_layout Plain Layout
+
+	Maybe (IQ -> StateT s m Bool),
+\end_layout
+
+\begin_layout Plain Layout
+
+	sessionTerminated :: Maybe (TerminationReason ->
+\end_layout
+
+\begin_layout Plain Layout
+
+	StateT s m ()) }
+\end_layout
+
+\end_inset
+
+
+\end_layout
+
+\begin_layout Standard
+ClientHandler is a record which specifies four callback functions.
+ The first three deals with the three XMPP stanzas, and are called once
+ an XMPP stanza is received.
+ These functions take the stanza in question, and are stateful with the
+ current client state.
+ The boolean value returned signals whether or not the message should be
+ blocked to clients further down the stack.
+ For example, a XEP-0030: Service Discovery handler may choose to hide disco#inf
+o requests handlers above it in the stack.
+ The last function is the callback that is used when the XMPP session is
+ terminated.
+ All callbacks are optional.
+\end_layout
+
+\begin_layout Standard
+The third argument to session is a callback function that will be called
+ when the session has been initialized.
+\end_layout
+
+\begin_layout Standard
+Any function with access to the Session object can operate with the XMPP
+ session, such as connecting the XMPP client or sending stanzas.
+ More on this below.
+\end_layout
+
+\begin_layout Subsection
+Connecting the client
+\end_layout
+
+\begin_layout Standard
+Different clients connect to XMPP in different ways.
+ Some secure the stream with TLS, and some authenticate with the server.
+ Pontarius XMPP provides a flexible function to help out with this in a
+ convenient way:
+\end_layout
+
+\begin_layout Standard
+\begin_inset listings
+inline false
+status open
+
+\begin_layout Plain Layout
+
+connect :: MonadIO m => Session s m -> HostName ->
+\end_layout
+
+\begin_layout Plain Layout
+
+	PortNumber -> Maybe (Certificate, (Certificate ->
+\end_layout
+
+\begin_layout Plain Layout
+
+	Bool)) -> Maybe (UserName, Password, Maybe
+\end_layout
+
+\begin_layout Plain Layout
+
+	Resource) -> (ConnectResult -> StateT s m ()) ->
+\end_layout
+
+\begin_layout Plain Layout
+
+	StateT s m ()
+\end_layout
+
+\end_inset
+
+
+\end_layout
+
+\begin_layout Standard
+This function simply takes the host name and port number to connect to,
+ an optional tuple of the certificate to use and a function evaluating certifica
+tes for TLS (if Nothing is provided, the connection will not be TLS secured),
+ and another optional tuple with user name, password, and an optional resource
+ for authentication (analogously, providing Nothing here causes Pontarius
+ XMPP not to authenticate).
+ The final paramter is a callback function providing the result of the connect
+ action.
+\end_layout
+
+\begin_layout Standard
+For more fine-grained control of the connection, use the openStream, secureWithT
+LS, and authenticate functions.
+\end_layout
+
+\begin_layout Subsection
+Managing XMPP addresses
+\end_layout
+
+\begin_layout Standard
+There are four functions dealing with XMPP addresses (or JIDs, as they are
+ also called):
+\end_layout
+
+\begin_layout Standard
+\begin_inset listings
+inline false
+status open
+
+\begin_layout Plain Layout
+
+fromString :: String -> Maybe Address
+\end_layout
+
+\begin_layout Plain Layout
+
+fromStrings :: Maybe String -> String ->
+\end_layout
+
+\begin_layout Plain Layout
+
+	Maybe String -> Maybe Address
+\end_layout
+
+\begin_layout Plain Layout
+
+isBare :: Address -> Bool
+\end_layout
+
+\begin_layout Plain Layout
+
+isFull :: Address -> Bool
+\end_layout
+
+\end_inset
+
+
+\end_layout
+
+\begin_layout Standard
+These functions should be pretty self-explainatory to those who know the
+ XMPP: Core standard.
+ The fromString functions takes one to three strings and tries to construct
+ an XMPP address.
+ isBare and isFull checks whether or not the bare is full (has a resource
+ value).
+\end_layout
+
+\begin_layout Subsection
+Sending stanzas
+\end_layout
+
+\begin_layout Standard
+Sending messages is done using this function:
+\end_layout
+
+\begin_layout Standard
+\begin_inset listings
+inline false
+status open
+
+\begin_layout Plain Layout
+
+sendMessage :: MonadIO m => Session s m -> Message ->
+\end_layout
+
+\begin_layout Plain Layout
+
+	Maybe (Message -> StateT s m Bool) ->
+\end_layout
+
+\begin_layout Plain Layout
+
+	Maybe (Timeout, StateT s m ()) ->
+\end_layout
+
+\begin_layout Plain Layout
+
+	Maybe (StreamError -> StateT s m ()) ->
+\end_layout
+
+\begin_layout Plain Layout
+
+	StateT s m () 
+\end_layout
+
+\end_inset
+
+
+\end_layout
+
+\begin_layout Standard
+Like in section 3.2, the first parameter is the session object.
+ The second is the message (check the Message record type in the API).
+ The third parameter is an optional callback function to be executed if
+ a reply to the message is received.
+ The fourth parameter contains a Timeout (Integer) value, and a callback
+ that Pontarius XMPP will call when a reply has not been received in the
+ window of the timeout.
+ The last parameter is an optional callback that is called if a stream error
+ occurs.
+\end_layout
+
+\begin_layout Standard
+Presence and IQ stanzas are sent in a very similar way.
+\end_layout
+
+\begin_layout Standard
+Stanza IDs will be set for you if you leave them out.
+ If, however, you want to know what ID you send, you can acquire a stanza
+ ID by calling the getID function:
+\end_layout
+
+\begin_layout Standard
+\begin_inset listings
+inline false
+status open
+
+\begin_layout Plain Layout
+
+getID :: MonadIO m => Session s m -> StateT s m String
+\end_layout
+
+\end_inset
+
+
+\end_layout
+
+\begin_layout Subsection
+Concurrent usage
+\end_layout
+
+\begin_layout Standard
+Sometimes clients will want to perform XMPP actions from more than one thread,
+ or in other words, they want to perform actions from code that is not a
+ Pontarius XMPP callback.
+ For these use cases, use injectAction:
+\end_layout
+
+\begin_layout Standard
+\begin_inset listings
+inline false
+status open
+
+\begin_layout Plain Layout
+
+injectAction :: MonadIO m => Session s m ->
+\end_layout
+
+\begin_layout Plain Layout
+
+	Maybe (StateT s m Bool) -> StateT s m () ->
+\end_layout
+
+\begin_layout Plain Layout
+
+	StateT s m ()
+\end_layout
+
+\end_inset
+
+
+\end_layout
+
+\begin_layout Standard
+The second parameter is an optional predicate callback to be executed right
+ before the third parameter callback is called.
+ If it is provided and evaluates to False, then the action will not be called.
+ Otherwise, the action will be called.
+\end_layout
+
+\begin_layout Subsection
+Example echo server
+\end_layout
+
+\begin_layout Standard
+We provide an example to further illustrate the Pontarius XMPP API and to
+ make it easier for developers to get started with the library.
+ The program illustrates how to connect, authenticate, set a presence, and
+ echo all messages received.
+ It only uses one client handler.
+ The contents of this example may be used freely, as if it is in the public
+ domain.
+ You find it in the Examples directory of the Pontarius XMPP source code.
+\end_layout
+
+\end_body
+\end_document

Documentation/Software Design Description for Pontarius XMPP 1.0.lyx

@@ -0,0 +1,192 @@
+#LyX 2.0 created this file. For more info see http://www.lyx.org/
+\lyxformat 413
+\begin_document
+\begin_header
+\textclass article
+\use_default_options true
+\maintain_unincluded_children false
+\language english
+\language_package default
+\inputencoding auto
+\fontencoding global
+\font_roman default
+\font_sans default
+\font_typewriter default
+\font_default_family default
+\use_non_tex_fonts false
+\font_sc false
+\font_osf false
+\font_sf_scale 100
+\font_tt_scale 100
+
+\graphics default
+\default_output_format default
+\output_sync 0
+\bibtex_command default
+\index_command default
+\paperfontsize default
+\use_hyperref false
+\papersize default
+\use_geometry false
+\use_amsmath 1
+\use_esint 1
+\use_mhchem 1
+\use_mathdots 1
+\cite_engine basic
+\use_bibtopic false
+\use_indices false
+\paperorientation portrait
+\suppress_date false
+\use_refstyle 1
+\index Index
+\shortcut idx
+\color #008000
+\end_index
+\secnumdepth 3
+\tocdepth 3
+\paragraph_separation indent
+\paragraph_indentation default
+\quotes_language english
+\papercolumns 1
+\papersides 1
+\paperpagestyle default
+\tracking_changes false
+\output_changes false
+\html_math_output 0
+\html_css_as_file 0
+\html_be_strict false
+\end_header
+
+\begin_body
+
+\begin_layout Title
+Software Design Description for Pontarius XMPP 1.0 (First Draft)
+\end_layout
+
+\begin_layout Author
+The Pontarius Project
+\end_layout
+
+\begin_layout Date
+15th of June, 2011
+\end_layout
+
+\begin_layout Standard
+\begin_inset CommandInset toc
+LatexCommand tableofcontents
+
+\end_inset
+
+
+\end_layout
+
+\begin_layout Section
+Introduction
+\end_layout
+
+\begin_layout Standard
+Purpose
+\end_layout
+
+\begin_layout Standard
+Scope
+\end_layout
+
+\begin_layout Standard
+Definitions and acronyms
+\end_layout
+
+\begin_layout Section
+References
+\end_layout
+
+\begin_layout Section
+Decomposition description
+\end_layout
+
+\begin_layout Subsection
+Module decomposition
+\end_layout
+
+\begin_layout Subsection
+Concurrent process decomposition
+\end_layout
+
+\begin_layout Subsection
+Data decomposition
+\end_layout
+
+\begin_layout Section
+Dependency description
+\end_layout
+
+\begin_layout Subsection
+Intermodule dependencies
+\end_layout
+
+\begin_layout Subsection
+Interprocess dependencies
+\end_layout
+
+\begin_layout Subsection
+Data dependencies
+\end_layout
+
+\begin_layout Section
+Interface description
+\end_layout
+
+\begin_layout Subsection
+Module interface
+\end_layout
+
+\begin_layout Subsubsection
+Module 1 description
+\end_layout
+
+\begin_layout Subsubsection
+Module 2 description
+\end_layout
+
+\begin_layout Subsection
+Process interface
+\end_layout
+
+\begin_layout Subsubsection
+Process 1 description
+\end_layout
+
+\begin_layout Subsubsection
+Process 2 description
+\end_layout
+
+\begin_layout Section
+Detailed design
+\end_layout
+
+\begin_layout Subsection
+Module detailed design
+\end_layout
+
+\begin_layout Subsubsection
+Module 1 detail
+\end_layout
+
+\begin_layout Subsubsection
+Module 2 detail
+\end_layout
+
+\begin_layout Subsection
+Data detailed design
+\end_layout
+
+\begin_layout Subsubsection
+Module 1 detail
+\end_layout
+
+\begin_layout Subsubsection
+Module 2 detail
+\end_layout
+
+\end_body
+\end_document

Documentation/Software Quality Assurance Plan for Pontarius XMPP 1.0.lyx

@@ -0,0 +1,324 @@
+#LyX 2.0 created this file. For more info see http://www.lyx.org/
+\lyxformat 413
+\begin_document
+\begin_header
+\textclass article
+\use_default_options true
+\maintain_unincluded_children false
+\language english
+\language_package default
+\inputencoding auto
+\fontencoding global
+\font_roman default
+\font_sans default
+\font_typewriter default
+\font_default_family default
+\use_non_tex_fonts false
+\font_sc false
+\font_osf false
+\font_sf_scale 100
+\font_tt_scale 100
+
+\graphics default
+\default_output_format default
+\output_sync 0
+\bibtex_command default
+\index_command default
+\paperfontsize default
+\use_hyperref false
+\papersize default
+\use_geometry false
+\use_amsmath 1
+\use_esint 1
+\use_mhchem 1
+\use_mathdots 1
+\cite_engine basic
+\use_bibtopic false
+\use_indices false
+\paperorientation portrait
+\suppress_date false
+\use_refstyle 1
+\index Index
+\shortcut idx
+\color #008000
+\end_index
+\secnumdepth 3
+\tocdepth 3
+\paragraph_separation indent
+\paragraph_indentation default
+\quotes_language english
+\papercolumns 1
+\papersides 1
+\paperpagestyle default
+\tracking_changes false
+\output_changes false
+\html_math_output 0
+\html_css_as_file 0
+\html_be_strict false
+\end_header
+
+\begin_body
+
+\begin_layout Title
+Software Quality Assurance Plan for Pontarius XMPP 1.0
+\end_layout
+
+\begin_layout Author
+Jon Kristensen
+\end_layout
+
+\begin_layout Date
+6th of June, 2011
+\end_layout
+
+\begin_layout Standard
+\begin_inset CommandInset toc
+LatexCommand tableofcontents
+
+\end_inset
+
+
+\end_layout
+
+\begin_layout Section
+Purpose
+\end_layout
+
+\begin_layout Standard
+The purpose of writing this SQAP is not only to increase the quality of
+ Pontarius XMPP, but also to evaluate the use of the IEEE Standard for Software
+ Quality Assurance Plans (IEEE Std 730-1998) standard as well as meeting
+ the goals of a university course in IT quality management.
+ For information on the intended use of the software, please consult the
+ Pontarius XMPP 1.0 Software Requirement Specification.
+ The applicable portions of the software's life cycle from its first beta
+ until its disposal phase.
+\end_layout
+
+\begin_layout Section
+Reference documents
+\end_layout
+
+\begin_layout Enumerate
+IEEE Standard for Software Quality Assurance Plans (IEEE Std 730-1998)
+\end_layout
+
+\begin_layout Enumerate
+Pontarius XMPP 1.0 Software Requirement Specification
+\end_layout
+
+\begin_layout Section
+Legal notice
+\end_layout
+
+\begin_layout Standard
+Pontarius XMPP is a free and open source software project.
+ The 
+\begin_inset Quotes eld
+\end_inset
+
+Pontarius project
+\begin_inset Quotes erd
+\end_inset
+
+ is not a legal entity, but is like a synonym for Jon Kristensen.
+ Jon Kristensen does DOES NOT TAKE ANY RESPONSIBILITY OR OFFER ANY GUARANTEES
+ in regards to the software, its quality or this document.
+ Furthermore, the software is provided 
+\begin_inset Quotes eld
+\end_inset
+
+WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+ or FITNESS FOR A PARTICULAR PURPOSE
+\begin_inset Quotes erd
+\end_inset
+
+.
+ Consult the GNU General Public License for more information.
+ This aspect particularly influences the next section of this document.
+\end_layout
+
+\begin_layout Section
+Management
+\end_layout
+
+\begin_layout Standard
+The 
+\begin_inset Quotes eld
+\end_inset
+
+organization
+\begin_inset Quotes erd
+\end_inset
+
+ behind the software is the project founder, project leader, and copyright
+ holder Jon Kristensen, which acts in a 
+\begin_inset Quotes eld
+\end_inset
+
+benevolent dictator
+\begin_inset Quotes erd
+\end_inset
+
+ position for the free and open source project.
+ The Pontarius project hopes that Pontarius XMPP will grow to become the
+ de-facto XMPP library for Haskell, and that we will get voluntary feedback
+ from multiple testers from different communities, such as the Haskell and
+ XMPP communities, as well as the free and open source software community
+ as a whole.
+ We will do what we can to organize and act on that feedback; however, the
+ only person that has currently even 
+\emph on
+planned
+\emph default
+ to perform software quality assurance activities is Jon Kristensen.
+\end_layout
+
+\begin_layout Standard
+[Lifecycle of software, Sequence of tasks (with emphasis on activities),
+ relationships between tasks and major checkpoints]
+\end_layout
+
+\begin_layout Standard
+(Testing API, extending Pontarius XMPP with a set of RFCs and/or XEPs, unit
+ testing, performance testing, stress testing, code (un)coverage...)
+\end_layout
+
+\begin_layout Section
+Documentation
+\end_layout
+
+\begin_layout Subsection
+Purpose
+\end_layout
+
+\begin_layout Subsection
+Minimum documentation requirements
+\end_layout
+
+\begin_layout Subsubsection
+Software Requirements Specification
+\end_layout
+
+\begin_layout Subsubsection
+Software Design Description
+\end_layout
+
+\begin_layout Subsubsection
+Software Verification and Validation Plan
+\end_layout
+
+\begin_layout Subsubsection
+User Documentation
+\end_layout
+
+\begin_layout Subsubsection
+Software Configuration Management Plan
+\end_layout
+
+\begin_layout Section
+Standards, practices, conventions, and metrics
+\end_layout
+
+\begin_layout Subsection
+Purpose
+\end_layout
+
+\begin_layout Subsection
+Content
+\end_layout
+
+\begin_layout Section
+Reviews and audits
+\end_layout
+
+\begin_layout Subsection
+Purpose
+\end_layout
+
+\begin_layout Subsection
+Minimum requirements
+\end_layout
+
+\begin_layout Subsection
+Software Requirements Review
+\end_layout
+
+\begin_layout Subsection
+Preliminary Design Review
+\end_layout
+
+\begin_layout Subsection
+Critical Design Review
+\end_layout
+
+\begin_layout Subsection
+Software Verification and Validation Plan Review
+\end_layout
+
+\begin_layout Subsubsection
+Functional audit
+\end_layout
+
+\begin_layout Subsubsection
+Physical audit
+\end_layout
+
+\begin_layout Subsubsection
+In-process audits
+\end_layout
+
+\begin_layout Subsubsection
+Manegerial reviews
+\end_layout
+
+\begin_layout Subsubsection
+Software Configuration Management Plan Review
+\end_layout
+
+\begin_layout Subsubsection
+Post-mortem review
+\end_layout
+
+\begin_layout Subsubsection
+User Documentation Review
+\end_layout
+
+\begin_layout Subsection
+Test
+\end_layout
+
+\begin_layout Section
+Problem reporting and corrective actions
+\end_layout
+
+\begin_layout Section
+Tools, technologies, and methodologies
+\end_layout
+
+\begin_layout Section
+Code control
+\end_layout
+
+\begin_layout Section
+Media control
+\end_layout
+
+\begin_layout Section
+Supplier control
+\end_layout
+
+\begin_layout Section
+Records collection, maintainance, and retention
+\end_layout
+
+\begin_layout Section
+Training
+\end_layout
+
+\begin_layout Section
+Risk management
+\end_layout
+
+\end_body
+\end_document

Examples/EchoClient.hs

@@ -0,0 +1,147 @@
+{-
+
+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 #-}
+
+
+module Examples.EchoClient () where
+
+import Network.XMPP
+
+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.
+
+hostName = "jonkristensen.com"
+userName = "pontarius"
+serverIdentifier = "jonkristensen.com"
+portNumber = 5222
+resource = "echo-client"
+password = ""
+
+
+-- 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
+  session
+    defaultState
+    clientHandlers
+    sessionCreated
+
+
+-- 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
+  id <- getID (DM.fromJust $ stateSession state)
+  CMIC.liftIO $ putStrLn $ "Unique ID acquired: " ++ id
+  injectAction (DM.fromJust $ stateSession state) Nothing (do CMIC.liftIO $ putStrLn "Async action!"; return ())
+  injectAction (DM.fromJust $ stateSession state) Nothing (do CMIC.liftIO $ putStrLn "Async action!"; return ())
+  injectAction (DM.fromJust $ stateSession state) Nothing (do CMIC.liftIO $ putStrLn "Async action!"; return ())
+  injectAction (DM.fromJust $ stateSession state) Nothing (do CMIC.liftIO $ putStrLn "Async action!"; return ())
+  injectAction (DM.fromJust $ stateSession state) Nothing (do CMIC.liftIO $ putStrLn "Async action!"; return ())
+  injectAction (DM.fromJust $ stateSession state) Nothing (do CMIC.liftIO $ putStrLn "Async action!"; return ())
+  injectAction (DM.fromJust $ stateSession state) Nothing (do CMIC.liftIO $ putStrLn "Async action!"; return ())
+  injectAction (DM.fromJust $ stateSession state) Nothing (do CMIC.liftIO $ putStrLn "Async action!"; return ())
+  injectAction (DM.fromJust $ stateSession state) Nothing (do CMIC.liftIO $ putStrLn "Async action!"; return ())
+  injectAction (DM.fromJust $ stateSession state) Nothing (do CMIC.liftIO $ putStrLn "Async action!"; return ())
+  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 { presenceID = Nothing
+                 , presenceFrom = Nothing
+                 , presenceTo = Nothing
+                 , presenceXMLLang  = Nothing
+                 , presenceType = Available
+                 , presencePayload = [] }
+        Nothing Nothing Nothing
+    _ -> do
+      CMIC.liftIO $ putStrLn "Could not connect."
+      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 { messageID = messageID m
+            , messageFrom = Nothing
+            , messageTo = messageFrom m
+            , messageXMLLang = Nothing
+            , messageType = messageType m
+            , messagePayload = messagePayload m }
+    Nothing (Just (0, (do CMIC.liftIO $ putStrLn "Timeout!"; return ()))) Nothing
+  return True

LICENSE

@@ -0,0 +1,4 @@
+Copyright © 2010-2011, Jon Kristensen.
+
+Pontarius XMPP is licensed under GNU Lesser General Public License, version 3.
+See COPYING and COPYING.LESSER for more information.

Network/XMPP.hs

@@ -0,0 +1,106 @@
+{-
+
+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 <http://www.gnu.org/licenses/>.
+
+-}
+
+-- | Module:      $Header$
+--   Description: A minimalistic and easy-to-use XMPP library
+--   Copyright:   Copyright © 2010-2011 Jon Kristensen
+--   License:     LGPL-3
+--
+--   Maintainer:  info@pontarius.org
+--   Stability:   unstable
+--   Portability: portable
+
+--   Pontarius XMPP aims to be a secure, concurrent/event-based and easy-to-use
+--   XMPP library for Haskell. It is being actively developed.
+--
+--   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
+--   <http://www.pontarius.org/> for more information.
+--
+--   This module will be documented soon.
+
+module Network.XMPP ( -- Network.XMPP.JID
+                      Address (..)
+                      , Localpart
+                      , Serverpart
+                      , Resourcepart
+                    , isFull
+                    , isBare
+                    , fromString
+                    , fromStrings
+
+                      -- Network.XMPP.SASL
+                    , replyToChallenge1
+
+                      -- Network.XMPP.Session
+                    , Certificate
+                    , ClientHandler (..)
+                    , ClientState (..)
+                    , ConnectResult (..)
+                    , HostName
+                    , Password
+                    , PortNumber
+                    , Resource
+                    , Session
+                    , TerminationReason
+                    , UserName
+                    , sendIQ
+                    , sendPresence
+                    , sendMessage
+                    , connect
+                    , openStream
+                    , secureWithTLS
+                    , authenticate
+                    , session
+                    , OpenStreamResult (..)
+                    , SecureWithTLSResult (..)
+                    , AuthenticateResult (..)
+
+                      -- Network.XMPP.Stanza
+                    , StanzaID (SID)
+                    , From
+                    , To
+                    , XMLLang
+                    , MessageType (..)
+                    , Message (..)
+                    , PresenceType (..)
+                    , Presence (..)
+                    , IQ (..)
+                    , iqPayloadNamespace
+                    , iqPayload
+
+                    , injectAction
+
+                    -- Network.XMPP.Utilities
+                    , elementToString
+                    , elementsToString
+                    , getID ) where
+
+import Network.XMPP.Address
+import Network.XMPP.SASL
+import Network.XMPP.Session
+import Network.XMPP.Stanza
+import Network.XMPP.Utilities
+import Network.XMPP.Types
+import Network.XMPP.TLS
+import Network.XMPP.Stream
+

Network/XMPP/Address.hs

@@ -0,0 +1,216 @@
+{-
+
+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 <http://www.gnu.org/licenses/>.
+
+-}
+
+
+-- TODO: Move away from stringprep for all three profiles.
+
+-- TODO: When no longer using stringprep, do appropriate testing. (Including
+-- testing addresses like a@b/c@d/e, a/b@c, a@/b, a/@b...)
+
+-- TODO: Unicode 3.2 should be used.
+
+
+-- |
+-- Module:      $Header$
+-- Description: Data type and utility functions for XMPP addresses (JIDs)
+-- Copyright:   Copyright © 2010-2011 Jon Kristensen
+-- License:     LGPL-3
+--
+-- Maintainer:  info@pontarius.org
+-- Stability:   unstable
+-- Portability: portable
+--
+-- This module deals with XMPP addresses (also known as JIDs and JabberIDs). For
+-- more information on XMPP addresses, see RFC 6122: XMPP: Address Format.
+--
+-- Provided hostnames may contain international characters; Pontarius XMPP will
+-- try to convert such hostnames to internationalized hostnames.
+
+
+module Network.XMPP.Address (fromString, fromStrings, isBare, isFull) where
+
+import Network.XMPP.Types
+
+import Data.Maybe (fromJust, isJust)
+import Text.Parsec ((<|>), anyToken, char, eof, many, noneOf, parse)
+import Text.Parsec.ByteString (GenParser)
+
+import Text.StringPrep (StringPrepProfile (..), a1, b1, b2, c11, c12, c21, c22,
+                        c3, c4, c5, c6, c7, c8, c9, runStringPrep)
+import Text.NamePrep (namePrepProfile)
+
+import Data.Text.IDNA2008 (toASCII)
+
+import Network.URI (isIPv4address, isIPv6address)
+
+import qualified Data.ByteString.Char8 as DBC (pack)
+import qualified Data.Text as DT (pack, unpack)
+
+
+-- |
+-- Converts a string to an XMPP address.
+
+fromString :: String -> Maybe Address
+
+fromString s = fromStrings localpart serverpart resourcepart
+    where
+        Right (localpart, serverpart, resourcepart) =
+            parse addressParts "" (DBC.pack s)
+
+
+-- |
+-- Converts localpart, serverpart, and resourcepart strings to an XMPP address.
+
+-- Runs the appropriate stringprep profiles and validates the parts.
+
+fromStrings :: Maybe String -> String -> Maybe String -> Maybe Address
+
+fromStrings l s r
+    | serverpart == Nothing = Nothing
+    | otherwise = if validateNonServerpart localpart &&
+                     isJust serverpart' &&
+                     validateNonServerpart resourcepart
+                  then Just (Address localpart (fromJust serverpart') resourcepart)
+                  else Nothing
+    where
+
+        -- Applies the nodeprep profile on the localpart string, if any.
+        localpart :: Maybe String
+        localpart = case l of
+            Just l' -> case runStringPrep nodeprepProfile (DT.pack l') of
+                Just l'' -> Just $ DT.unpack l''
+                Nothing -> Nothing
+            Nothing -> Nothing
+
+        -- Applies the nameprep profile on the serverpart string.
+        -- TODO: Allow unassigned?
+        serverpart :: Maybe String
+        serverpart = case runStringPrep (namePrepProfile False) (DT.pack s) of
+            Just s' -> Just $ DT.unpack s'
+            Nothing -> Nothing
+
+        -- Applies the resourceprep profile on the resourcepart string, if any.
+        resourcepart :: Maybe String
+        resourcepart = case r of
+            Just r' -> case runStringPrep resourceprepProfile (DT.pack r') of
+                Just r'' -> Just $ DT.unpack r''
+                Nothing -> Nothing
+            Nothing -> Nothing
+
+        -- Returns the serverpart if it was a valid IP or if the toASCII
+        -- function was successful, or Nothing otherwise.
+        serverpart' :: Maybe String
+        serverpart' | isIPv4address s || isIPv6address s = Just s
+                    | otherwise = toASCII s
+
+        -- Validates that non-serverpart strings have an appropriate length.
+        validateNonServerpart :: Maybe String -> Bool
+        validateNonServerpart Nothing = True
+        validateNonServerpart (Just l) = validPartLength l
+            where
+                validPartLength :: String -> Bool
+                validPartLength p = length p > 0 && length p < 1024
+
+
+-- | Returns True if the address is `bare', and False otherwise.
+
+isBare :: Address -> Bool
+
+isBare j | resourcepart j == Nothing = True
+         | otherwise                 = False
+
+
+-- | Returns True if the address is `full', and False otherwise.
+
+isFull :: Address -> Bool
+
+isFull jid = not $ isBare jid
+
+
+-- Parses an address string and returns its three parts. It performs no
+-- validation or transformations. We are using Parsec to parse the address.
+-- There is no input for which 'addressParts' fails.
+
+addressParts :: GenParser Char st (Maybe String, String, Maybe String)
+
+addressParts = do
+
+    -- Read until we reach an '@', a '/', or EOF.
+    a <- many $ noneOf ['@', '/']
+
+    -- Case 1: We found an '@', and thus the localpart. At least the serverpart
+    -- is remaining. Read the '@' and until a '/' or EOF.
+    do
+        char '@'
+        b <- many $ noneOf ['/']
+
+        -- Case 1A: We found a '/' and thus have all the address parts. Read the
+        -- '/' and until EOF.
+        do
+            char '/' -- Resourcepart remaining
+            c <- many $ anyToken -- Parse resourcepart
+            eof
+            return (Just a, b, Just c)
+
+        -- Case 1B: We have reached EOF; the address is in the form
+        -- localpart@serverpart.
+            <|> do
+                eof
+                return (Just a, b, Nothing)
+
+        -- Case 2: We found a '/'; the address is in the form
+        -- serverpart/resourcepart.
+        <|> do
+            char '/'
+            b <- many $ anyToken
+            eof
+            return (Nothing, a, Just b)
+
+        -- Case 3: We have reached EOF; we have an address consisting of only a
+        -- serverpart.
+        <|> do
+            eof
+            return (Nothing, a, Nothing)
+
+
+nodeprepProfile :: StringPrepProfile
+
+nodeprepProfile = Profile { maps = [b1, b2]
+                          , shouldNormalize = True
+                          , prohibited = [a1] ++ [c11, c12, c21, c22, c3, c4, c5, c6, c7, c8, c9]
+                          , shouldCheckBidi = True }
+
+
+-- These needs to be checked for after normalization. We could also look up the
+-- Unicode mappings and include a list of characters in the prohibited field
+-- above. Let's defer that until we know that we are going to use stringprep.
+
+nodeprepExtraProhibitedCharacters = ['\x22', '\x26', '\x27', '\x2F', '\x3A',
+                                     '\x3C', '\x3E', '\x40']
+
+
+
+resourceprepProfile :: StringPrepProfile
+
+resourceprepProfile = Profile { maps = [b1]
+                          , shouldNormalize = True
+                          , prohibited = [a1] ++ [c12, c21, c22, c3, c4, c5, c6, c7, c8, c9]
+                          , shouldCheckBidi = True }

Network/XMPP/SASL.hs

@@ -0,0 +1,215 @@
+{-
+
+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 <http://www.gnu.org/licenses/>.
+
+-}
+
+-- 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?
+
+module Network.XMPP.SASL (replyToChallenge1) where
+
+import Data.ByteString.Internal (c2w)
+import Data.Char (isLatin1)
+import Data.Digest.Pure.MD5
+import qualified Data.Binary as DBi (Binary, encode)
+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.List as DL
+
+
+data Challenge1Error = C1MultipleCriticalAttributes       |
+                       C1NotAllParametersPresent          |
+                       C1SomeParamtersPresentMoreThanOnce |
+                       C1WrongRealm                       |
+                       C1UnsupportedAlgorithm             |
+                       C1UnsupportedCharset               |
+                       C1UnsupportedQOP
+                       deriving Show
+
+
+-- Will produce a list of key-value pairs given a string in the format of
+-- realm="somerealm",nonce="OA6MG9tEQGm2hh",qop="auth",charset=utf-8...
+stringToList :: String -> [(String, String)]
+stringToList "" = []
+stringToList s' = let (next, rest) = break' s' ','
+                  in break' next '=' : stringToList rest
+  where
+    -- Like break, but will remove the first char of the continuation, if
+    -- present.
+    break' :: String -> Char -> (String, String)
+    break' s' c = let (first, second) = break ((==) c) s'
+                  in (first, removeCharIfPresent second c)
+    
+    -- Removes the first character, if present; "=hello" with '=' becomes
+    -- "hello".
+    removeCharIfPresent :: String -> Char -> String
+    removeCharIfPresent [] _               = []
+    removeCharIfPresent (c:t) c' | c == c' = t
+    removeCharIfPresent s' c               = s'
+
+-- Counts the number of directives in the pair list.
+countDirectives :: String -> [(String, String)] -> Int
+countDirectives v l = DL.length $ filter (isEntry v) l
+  where
+    isEntry :: String -> (String, String) -> Bool
+    isEntry name (name', _) | name == name' = True
+                            | otherwise     = False
+
+
+-- Returns the given directive in the list of pairs, or Nothing.
+lookupDirective :: String -> [(String, String)] -> Maybe String
+lookupDirective d []                      = Nothing
+lookupDirective d ((d', v):t) | d == d'   = Just v
+                              | otherwise = lookupDirective d t
+
+
+-- Returns the given directive in the list of pairs, or the default value
+-- otherwise.
+lookupDirectiveWithDefault :: String -> [(String, String)] -> String -> String
+lookupDirectiveWithDefault di l de
+  | lookup == Nothing = de
+  | otherwise         = let Just r = lookup in r
+  where
+    lookup = lookupDirective di l
+
+
+-- Takes a challenge string (which is not Base64-encoded), the host name of the
+-- Jabber server, the Jabber user name (JID), the password and a random and
+-- unique "cnonce" value and generates either an error or a response to that
+-- challenge.
+
+-- We have broken replyToChallenge1 for non-TLS authentication. In order to
+-- change it back, just uncomment the lines relevant to the realm and match it
+-- in the C1NotAllParametersSet case.
+
+replyToChallenge1 :: String -> String -> String -> String -> String ->
+                     Either String Challenge1Error
+replyToChallenge1 s h u p c =
+  -- Remove all new line characters.
+  let list = stringToList $ filter (/= '\n') s
+  in -- Count that there are no more than one nonce or algorithm directives.
+     case countDirectives "nonce"     list <= 1 &&
+          countDirectives "algorithm" list <= 1 of
+       True ->
+         let -- realm     = lookupDirective "realm" list
+             nonce     = lookupDirective "nonce" list
+             qop       = lookupDirectiveWithDefault "qop" list "auth"
+             charset   = lookupDirectiveWithDefault "charset" list "utf-8"
+             algorithm = lookupDirective "algorithm" list
+         
+         -- Verify that all necessary directives has been set.
+         in case (nonce, qop, charset, algorithm) of
+              (Just nonce', qop', charset', Just algorithm') ->
+                
+                -- Strip quotations of the directives that need it.
+                let -- realm'' = stripQuotations realm'
+                    nonce'' = stripQuotations nonce'
+                    qop'' = stripQuotations qop' -- It seems ejabberd gives us an errorous "auth" instead of auth
+                in
+                -- -- Verify that the realm is the same as the Jabber host.
+                -- case realm'' == h of
+                --      True ->
+                       
+                       -- Verify that QOP is "auth", charset is "utf-8" and that
+                       -- the algorithm is "md5-sess".
+                       case qop'' == "auth" of
+                         True ->
+                           case charset' == "utf-8" of
+                             True ->
+                               case algorithm' == "md5-sess" of
+                                 True ->
+                                 
+                                   -- All data is valid; generate the reply.
+                                   Left (reply nonce'' qop'')
+                                 
+                                 -- Errors are caught and reported below.
+                                 False -> Right C1UnsupportedAlgorithm
+                             False -> Right C1UnsupportedCharset
+                         False -> Right C1UnsupportedQOP
+                     -- False -> Right C1WrongRealm
+              _ -> Right C1NotAllParametersPresent
+  where
+    reply n q =
+      let -- We start with what's in RFC 2831 is referred to as "A1", a 16 octet
+          -- MD5 hash.
+          
+          -- If the username or password values are in ISO-8859-1, we convert
+          -- them to ISO-8859-1 strings.
+          username = case all isLatin1 u of
+            True -> DBL.pack $ map c2w u
+            False -> DBLC.pack $ u
+          password = case all isLatin1 p of
+            True -> DBL.pack $ map c2w p
+            False -> DBLC.pack p
+          
+          nc = "00000001"
+          digestUri = "xmpp/" ++ h
+          
+          -- Build the "{ username-value, ":", realm-value, ":", passwd }"
+          -- bytestring, the rest of the bytestring and then join them.
+          a1a = DBi.encode $ md5 $ DBLC.append
+                (DBLC.append username (DBLC.pack (":" ++ h ++ ":")))
+                password
+          a1aDebug = "DBi.encode $ md5 $ " ++ (DBLC.unpack $ DBLC.append
+                (DBLC.append username (DBLC.pack (":" ++ h ++ ":")))
+                password)
+          a1b = DBLC.pack (":" ++ n ++ ":" ++ c)
+          a1 = DBLC.append a1a a1b
+          
+          -- Generate the "A2" value.
+          a2 = DBLC.pack ("AUTHENTICATE:" ++ digestUri)
+          
+          -- Produce the responseValue.
+          k = DBLC.pack (show $ md5 a1)
+          colon = DBLC.pack ":"
+          s0 = DBLC.pack (n ++ ":" ++ nc ++ ":" ++ c ++ ":" ++
+                          q ++ ":")
+          s1 = DBLC.pack $ show $ md5 a2
+          
+          s_ = DBLC.append s0 s1
+          -- append k:d and 16 octet hash it
+          kd = md5 (DBLC.append k (DBLC.append colon s_))
+          
+          lol0 = DBLC.unpack s_
+          lol1 = show kd
+          
+          response = show kd
+      in "username=\"" ++ u ++ "\",realm=\"" ++ h ++ "\",nonce=\"" ++ n ++
+         "\",cnonce=\"" ++ c ++ "\",nc=" ++ nc ++ ",digest-uri=\"" ++
+         digestUri ++ "\",qop=auth,response=" ++ response ++ ",charset=utf-8"
+         -- "\n\n" ++
+         -- "a1aDebug: " ++ a1aDebug ++ "\n" ++
+         -- "a1b: " ++ (DBLC.unpack a1b) ++ "\n" ++
+         -- "a1: " ++ (DBLC.unpack a1) ++ "\n" ++
+         -- "a2: " ++ (DBLC.unpack a2) ++ "\n" ++
+         -- "k: " ++ (DBLC.unpack k) ++ "\n" ++
+         -- "colon: " ++ (DBLC.unpack colon) ++ "\n" ++
+         -- "s0: " ++ (DBLC.unpack s0) ++ "\n" ++
+         -- "s1: " ++ (DBLC.unpack s1) ++ "\n" ++
+         -- "s_: " ++ (DBLC.unpack s_) ++ "\n"
+
+
+-- Stripts the quotations around a string, if any; "\"hello\"" becomes "hello".
+
+stripQuotations :: String -> String
+stripQuotations ""                                     = ""
+stripQuotations s | (head s == '"') && (last s == '"') = tail $ init s
+                  | otherwise                          = s

Network/XMPP/Session.hs

@@ -0,0 +1,758 @@
+{-
+
+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 <http://www.gnu.org/licenses/>.
+
+-}
+
+-- 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?
+
+-- 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 #-}
+
+-- |
+-- 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
+--
+-- 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 ( ClientHandler (..)
+                            , ClientState (..)
+                            , ConnectResult (..)
+                            , Session
+                            , TerminationReason
+                            , OpenStreamResult (..)
+                            , SecureWithTLSResult (..)
+                            , AuthenticateResult (..)
+                            , sendPresence
+                            , sendIQ
+                            , sendMessage
+                            , connect
+                            , openStream
+                            , secureWithTLS
+                            , authenticate
+                            , session
+                            , injectAction
+                            , getID ) where
+
+import Network.XMPP.Address
+import Network.XMPP.SASL
+import Network.XMPP.Stanza
+import Network.XMPP.Stream
+import Network.XMPP.TLS
+import Network.XMPP.Types
+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)
+                           , sessionIDGenerator :: IDGenerator }
+
+
+-- | 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 ()) }
+
+
+-- | @TerminationReason@ contains information on why the XMPP session was
+--   terminated.
+
+data TerminationReason = WhateverReason -- TODO
+
+
+-- | 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.
+
+session :: (MonadIO m, ClientState s m) => s -> [ClientHandler s m] ->
+           (CMS.StateT s m ()) -> m ()
+
+session s h c = do
+  threadID <- liftIO $ newEmptyMVar
+  chan <- liftIO $ newChan
+  idGenerator <- liftIO $ idGenerator "" -- TODO: Prefix
+  ((), clientState) <- runStateT c (putSession s $ session_ chan idGenerator)
+  (result, _) <- runStateT (stateLoop chan)
+                 (defaultState chan threadID h clientState idGenerator)
+  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 i = Session { sessionChannel = c, sessionIDGenerator = i }
+
+
+defaultState :: (MonadIO m, ClientState s m) => Chan (InternalEvent s m) -> MVar ThreadId ->
+                [ClientHandler s m] -> s -> IDGenerator -> State s m
+
+defaultState c t h s i = 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
+                               , statePresenceCallbacks = []
+                               , stateMessageCallbacks = []
+                               , stateIQCallbacks = []
+                               , stateTimeoutStanzaIDs = []
+                               , stateIDGenerator = i } -- TODO: Prefix
+
+
+connect :: MonadIO m => Session s m -> HostName -> PortNumber ->
+           Maybe (Certificate, (Certificate -> Bool)) ->
+           Maybe (UserName, Password, Maybe Resource) ->
+           (ConnectResult -> StateT s m ()) -> StateT s m ()
+
+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 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 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 u p r c)))
+
+
+sendMessage :: MonadIO m => Session s m -> Message -> Maybe (Message -> StateT s m Bool) -> Maybe (Timeout, StateT s m ()) -> Maybe (StreamError -> StateT s m ()) -> StateT s m ()
+sendMessage se m c t st = CMS.get >>=
+                  (\ state -> lift $ liftIO $
+                              writeChan (sessionChannel se)
+                              (IEC (CEMessage m c t st)))
+
+sendPresence :: MonadIO m => Session s m -> Presence -> Maybe (Presence -> StateT s m Bool) -> Maybe (Timeout, StateT s m ()) -> Maybe (StreamError -> StateT s m ()) -> StateT s m ()
+sendPresence se p c t st = CMS.get >>=
+                   (\ state -> lift $ liftIO $
+                               writeChan (sessionChannel se)
+                               (IEC (CEPresence p c t st)))
+
+sendIQ :: MonadIO m => Session s m -> IQ -> Maybe (IQ -> StateT s m Bool) -> Maybe (Timeout, StateT s m ()) -> Maybe (StreamError -> StateT s m ()) -> StateT s m ()
+sendIQ se i c t st = CMS.get >>=
+               (\ state -> lift $ liftIO $
+                           writeChan (sessionChannel se)
+                           (IEC (CEIQ i c t st)))
+
+injectAction :: MonadIO m => Session s m -> Maybe (StateT s m Bool) -> StateT s m () -> StateT s m ()
+injectAction s p a = CMS.get >>=
+               (\ state -> lift $ liftIO $
+                           writeChan (sessionChannel s)
+                           (IEC (CEAction p a)))
+
+getID :: MonadIO m => Session s m -> StateT s m String
+getID s = CMS.get >>= \ state -> lift $ liftIO $ nextID (sessionIDGenerator s) >>= \ id -> return id
+
+-- 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
+-- =============================================================================
+
+
+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 ())
+
+
+isConnected :: ConnectionState -> Bool
+isConnected Disconnected = True
+isConnected (Connected _ _) = True
+
+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
+        , stateOpenStreamCallback :: OpenStreamCallback s m
+        , stateSecureWithTLSCallback :: SecureWithTLSCallback s m
+        , stateAuthenticateCallback :: AuthenticateCallback s m
+        , stateAuthenticationState :: AuthenticationState
+        , stateResource :: Maybe Resource
+        , stateShouldExit :: Bool
+        , stateThreadID :: MVar ThreadId
+        , statePresenceCallbacks :: [(StanzaID, (Presence -> StateT s m Bool))]
+        , stateMessageCallbacks :: [(StanzaID, (Message -> StateT s m Bool))]
+        , stateIQCallbacks :: [(StanzaID, (IQ -> StateT s m Bool))]
+        , stateTimeoutStanzaIDs :: [StanzaID]
+        , stateIDGenerator :: IDGenerator
+        }
+
+
+-- 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 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 ("<?xml version='1.0'?><stream:stream to='" ++ hostName ++
+          "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.or" ++
+          "g/streams' version='1.0'>") (Left handle)
+        threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Left handle)
+        lift $ liftIO $ putMVar (stateThreadID state) threadID
+        return Nothing
+      Left e -> do
+        let clientState = stateClientState state
+        ((), clientState') <- lift $ runStateT (callback OpenStreamFailure) clientState
+        put $ state { stateShouldExit = True }
+        return $ Just e
+
+  IEC (CESecureWithTLS certificate verifyCertificate callback) -> do
+    -- CEB.assert (not $ isTLSSecured (stateStreamState state)) (return ())
+    let Connected _ handle = stateConnectionState state
+    lift $ liftIO $ send "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>" (Left handle)
+    put $ state { stateStreamState = PreStream
+                , stateSecureWithTLSCallback = Just callback }
+    return Nothing
+
+-- TODO: Save callback in state.
+  IEC (CEAuthenticate 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 "<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='DIGEST-MD5'/>" 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 ("<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:param" ++ "s:xml:ns:xmpp-bind\"></bind></iq>") handleOrTLSCtx
+              return ()
+            _ -> do
+              lift $ liftIO $ send ("<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:param" ++ "s:xml:ns:xmpp-bind\"><resource>" ++ fromJust resource ++ "</resource></bind></iq>") handleOrTLSCtx
+              return ()
+          id <- liftIO $ nextID $ stateIDGenerator state
+          lift $ liftIO $ send ("<iq type=\"set\" id=\"" ++ id ++ "\"><session xmlns=\"urn:ietf:params:xml:ns:xmpp-session\"/>" ++ "</iq>") 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" }
+          state' <- get
+          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) (stateIDGenerator 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 ("<?xml version='1.0'?><stream:stream to='" ++
+      hostName ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++
+      "streams' version='1.0'>") (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
+        id <- liftIO $ nextID $ stateIDGenerator state
+        -- This is the first challenge - we need to calculate the reply
+        case replyToChallenge1 challenge' serverHost userName password id of
+          Left reply -> do
+            let reply' = (filter (/= '\n') (CBBS.encode reply))
+            lift $ liftIO $ send ("<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>" ++ reply' ++ "</response>") handleOrTLSCtx
+            put $ state { stateAuthenticationState = AuthenticatingPreChallenge2 userName password resource }
+            return ()
+          Right error -> do
+            state' <- get
+            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 "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/>" 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: <?xml version='1.0'?>?
+  IEE (EnumeratorXML (XESuccess (Succ _))) -> do
+    let serverHost = "jonkristensen.com"
+    let AuthenticatingPreSuccess userName _ resource = stateAuthenticationState state in do
+      lift $ liftIO $ send ("<?xml version='1.0'?><stream:stream to='" ++ serverHost ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++ "streams' version='1.0'>") 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)) ->
+    case shouldIgnoreIQ iqEvent of
+        True ->
+            return Nothing
+        False -> do
+            let stanzaID' = iqID iqEvent
+            let newTimeouts = case stanzaID' of
+                                Just stanzaID'' ->
+                                    case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of
+                                                True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state)
+                                                False -> (stateTimeoutStanzaIDs state)
+                                Nothing -> (stateTimeoutStanzaIDs state)
+            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 $ iqID $ iqEvent) (stateIQCallbacks state) of
+                                  Just f -> (Just (f $ iqEvent)):functions
+                                  Nothing -> functions
+            let clientState = stateClientState state
+            clientState' <- sendToClient functions' clientState
+            put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts }
+            return Nothing
+
+  IEE (EnumeratorXML (XEPresence presenceEvent)) -> do
+    let stanzaID' = presenceID $ presenceEvent
+    let newTimeouts = case stanzaID' of
+                        Just stanzaID'' ->
+                            case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of
+                                    True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state)
+                                    False -> (stateTimeoutStanzaIDs state)
+                        Nothing -> (stateTimeoutStanzaIDs state)
+    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', stateTimeoutStanzaIDs = newTimeouts }
+    return Nothing
+
+  IEE (EnumeratorXML (XEMessage messageEvent)) -> do
+    let stanzaID' = messageID $ messageEvent
+    let newTimeouts = case stanzaID' of
+                        Just stanzaID'' ->
+                            case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of
+                                    True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state)
+                                    False -> (stateTimeoutStanzaIDs state)
+                        Nothing -> (stateTimeoutStanzaIDs state)
+    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', stateTimeoutStanzaIDs = newTimeouts }
+    return Nothing
+
+  IEC (CEPresence presence stanzaCallback timeoutCallback streamErrorCallback) -> do
+    presence' <- case presenceID $ presence of
+      Nothing -> do
+        id <- liftIO $ nextID $ stateIDGenerator state
+        return $ presence { presenceID = Just (SID id) }
+      _ -> return presence
+    case timeoutCallback of
+        Just (t, timeoutCallback') ->
+            let stanzaID' = (fromJust $ presenceID $ presence') in do
+                registerTimeout (stateChannel state) stanzaID' t timeoutCallback'
+                put $ state { stateTimeoutStanzaIDs = stanzaID':(stateTimeoutStanzaIDs state) }
+        Nothing ->
+            return ()
+    let xml = presenceToXML presence'
+    lift $ liftIO $ send xml handleOrTLSCtx
+    return Nothing
+
+  IEC (CEMessage message stanzaCallback timeoutCallback streamErrorCallback) -> do
+    message' <- case messageID message of
+      Nothing -> do
+        id <- liftIO $ nextID $ stateIDGenerator state
+        return $ message { messageID = Just (SID id) }
+      _ -> return message
+    case timeoutCallback of
+        Just (t, timeoutCallback') ->
+            let stanzaID' = (fromJust $ messageID message') in do
+                registerTimeout (stateChannel state) stanzaID' t timeoutCallback'
+                put $ state { stateTimeoutStanzaIDs = stanzaID':(stateTimeoutStanzaIDs state) }
+        Nothing ->
+            return ()
+    let xml = messageToXML message'
+    lift $ liftIO $ send xml handleOrTLSCtx
+    return Nothing
+
+  IEC (CEIQ iq stanzaCallback timeoutCallback stanzaErrorCallback) -> do
+    iq' <- case iqID iq of
+      Nothing -> do
+        id <- liftIO $ nextID $ stateIDGenerator state
+        return $ case iq of
+          IQReq r -> do
+            IQReq (r { iqRequestID = Just (SID id) })
+          IQRes r -> do
+            IQRes (r { iqResponseID = Just (SID id) })
+      _ -> return iq
+    case stanzaCallback of
+      Just callback' -> case iq of
+        IQReq {} -> put $ state { stateIQCallbacks = (fromJust $ iqID iq, callback'):(stateIQCallbacks state) }
+        _ -> return ()
+      Nothing -> return ()
+    case timeoutCallback of
+        Just (t, timeoutCallback') ->
+            let stanzaID' = (fromJust $ iqID iq') in do
+                registerTimeout (stateChannel state) stanzaID' t timeoutCallback'
+                put $ state { stateTimeoutStanzaIDs = stanzaID':(stateTimeoutStanzaIDs state) }
+        Nothing ->
+            return ()
+    -- TODO: Bind ID to callback
+    let xml = iqToXML iq'
+    lift $ liftIO $ send xml handleOrTLSCtx
+    return Nothing
+
+  IEC (CEAction predicate callback) -> do
+    case predicate of
+        Just predicate' -> do
+            result <- runBoolClientCallback predicate'
+            case result of
+                True -> do
+                    runUnitClientCallback callback
+                    return Nothing
+                False -> return Nothing
+        Nothing -> do
+            runUnitClientCallback callback
+            return Nothing
+
+  -- XOEDisconnect -> do
+  --   -- TODO: Close stream
+  --   return ()
+
+  IET (TimeoutEvent i t c) ->
+    case i `elem` (stateTimeoutStanzaIDs state) of
+        True -> do
+            runUnitClientCallback c
+            return Nothing
+        False -> return Nothing
+
+
+  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
+
+
+registerTimeout :: (ClientState s m, MonadIO m) => Chan (InternalEvent s m) -> StanzaID -> Timeout -> StateT s m () -> StateT (State s m) m ()
+registerTimeout ch i t ca = do
+    liftIO $ threadDelay $ t * 1000
+    liftIO $ forkIO $ writeChan ch $ IET (TimeoutEvent i t ca)
+    return ()
+
+
+runBoolClientCallback :: (ClientState s m, MonadIO m) => StateT s m Bool -> StateT (State s m) m Bool
+runBoolClientCallback c = do
+    state <- get
+    let clientState = stateClientState state
+    (bool, clientState') <- lift $ runStateT c clientState
+    put $ state { stateClientState = clientState' }
+    return bool
+
+
+runUnitClientCallback :: (ClientState s m, MonadIO m) => StateT s m () -> StateT (State s m) m ()
+runUnitClientCallback c = do
+    state <- get
+    let clientState = stateClientState state
+    ((), clientState') <- lift $ runStateT c clientState
+    put $ state { stateClientState = clientState' }
+
+
+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'

Network/XMPP/Stanza.hs

@@ -0,0 +1,182 @@
+{-
+
+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 <http://www.gnu.org/licenses/>.
+
+-}
+
+-- |
+-- Module:      $Header$
+-- Description: XMPP stanza types and utility functions
+-- Copyright:   Copyright © 2010-2011 Jon Kristensen
+-- License:     LGPL-3
+--
+-- Maintainer:  info@pontarius.org
+-- Stability:   unstable
+-- Portability: portable
+--
+-- The stanza record types are generally pretty convenient to work with.
+-- However, due to the fact that an "IQ" can be both an "IQRequest" and an
+-- "IQResponse" we provide some helper functions in this module that work on
+-- both types.
+--
+-- We also provide functions to create a new stanza ID generator, and to
+-- generate new IDs.
+
+
+module Network.XMPP.Stanza (
+iqID,
+iqFrom,
+iqTo,
+iqXMLLang,
+iqPayload,
+iqPayloadNamespace,
+iqRequestPayloadNamespace,
+iqResponsePayloadNamespace,
+idGenerator,
+nextID
+) where
+
+import Network.XMPP.Address
+import Network.XMPP.Types
+
+import Data.IORef (atomicModifyIORef, newIORef)
+import Data.XML.Types (Element, elementName, nameNamespace)
+import Data.Text (unpack)
+
+
+-- |
+-- Returns the @StanzaID@ value of the @IQ@, if any.
+
+iqID :: IQ -> Maybe StanzaID
+
+iqID (IQReq i) = iqRequestID i
+iqID (IQRes i) = iqResponseID i
+
+
+-- |
+-- Returns the @From@ @JID@ value of the @IQ@, if any.
+
+iqFrom :: IQ -> Maybe From
+
+iqFrom (IQReq i) = iqRequestFrom i
+iqFrom (IQRes i) = iqResponseFrom i
+
+
+-- |
+-- Returns the @To@ @JID@ value of the @IQ@, if any.
+
+iqTo :: IQ -> Maybe To
+
+iqTo (IQReq i) = iqRequestTo i
+iqTo (IQRes i) = iqResponseTo i
+
+
+-- |
+-- Returns the @XMLLang@ value of the @IQ@, if any.
+
+iqXMLLang :: IQ -> Maybe XMLLang
+
+iqXMLLang (IQReq i) = iqRequestXMLLang i
+iqXMLLang (IQRes i) = iqResponseXMLLang i
+
+
+-- |
+-- Returns the @Element@ payload value of the @IQ@, if any. If the IQ in
+-- question is of the "request" type, use @iqRequestPayload@ instead.
+
+iqPayload :: IQ -> Maybe Element
+
+iqPayload (IQReq i) = Just (iqRequestPayload i)
+iqPayload (IQRes i) = iqResponsePayload i
+
+
+-- |
+-- Returns the namespace of the element of the @IQ@, if any.
+
+iqPayloadNamespace :: IQ -> Maybe String
+
+iqPayloadNamespace i = case iqPayload i of
+  Nothing -> Nothing
+  Just p -> case nameNamespace $ elementName p of
+    Nothing -> Nothing
+    Just n -> Just (unpack n)
+
+
+-- |
+-- Returns the namespace of the element of the @IQRequest@, if any.
+
+iqRequestPayloadNamespace :: IQRequest -> Maybe String
+
+iqRequestPayloadNamespace i = let p = iqRequestPayload i in
+  case nameNamespace $ elementName p of
+    Nothing -> Nothing
+    Just n -> Just (unpack n)
+
+
+-- |
+-- Returns the namespace of the element of the @IQRequest@, if any.
+
+iqResponsePayloadNamespace :: IQResponse -> Maybe String
+
+iqResponsePayloadNamespace i = case iqResponsePayload i of
+  Nothing -> Nothing
+  Just p -> case nameNamespace $ elementName p of
+    Nothing -> Nothing
+    Just n -> Just (unpack n)
+
+
+-- |
+-- Creates a new stanza "IDGenerator". Internally, it will maintain an infinite
+-- list of stanza IDs ('[\'a\', \'b\', \'c\'...]').
+
+idGenerator :: String -> IO IDGenerator
+
+idGenerator p = newIORef (ids p) >>= \ ioRef -> return $ IDGenerator ioRef
+
+
+-- |
+-- Extracts an ID from the "IDGenerator", and updates the generators internal
+-- state so that the same ID will not be generated again.
+
+nextID :: IDGenerator -> IO String
+
+nextID g = let IDGenerator ioRef = g
+           in atomicModifyIORef ioRef (\ (i:is) -> (is, i))
+
+
+-- Generates an infinite and predictable list of IDs, all beginning with the
+-- provided prefix.
+
+ids :: String -> [String]
+
+-- Adds the prefix to all combinations of IDs (ids').
+ids p = map (\ id -> p ++ id) ids'
+    where
+
+        -- Generate all combinations of IDs, with increasing length.
+        ids' :: [String]
+        ids' = concatMap ids'' [1..]
+
+        -- Generates all combinations of IDs with the given length.
+        ids'' :: Integer -> [String]
+        ids'' 0 = [""]
+        ids'' l = [x:xs | x <- repertoire, xs <- ids'' (l - 1)]
+
+        -- Characters allowed in IDs.
+        repertoire :: String
+        repertoire = ['a'..'z']

Network/XMPP/Stream.hs

@@ -0,0 +1,457 @@
+-----------------------------------------------------------------------------
+--
+-- Module      :  Network.XMPP.Stream
+-- Copyright   :  Copyright © 2011, Jon Kristensen
+-- License     :  UnknownLicense "LGPL3"
+--
+-- Maintainer  :  jon.kristensen@pontarius.org
+-- Stability   :  alpha
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Network.XMPP.Stream (
+isTLSSecured,
+xmlEnumerator,
+xmlReader,
+presenceToXML,
+iqToXML,
+messageToXML,
+parsePresence,
+parseIQ,
+parseMessage
+) where
+
+import Network.XMPP.Address hiding (fromString)
+import qualified Network.XMPP.Address as X
+import Network.XMPP.Types
+import Network.XMPP.Utilities
+import Network.XMPP.TLS
+import Network.XMPP.Stanza
+import qualified Control.Exception as CE
+import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
+import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput)
+import Network.TLS
+import Network.TLS.Cipher
+import Data.Enumerator (($$), Iteratee, continue, joinI,
+                        run, run_, yield)
+import Data.Enumerator.Binary (enumHandle, enumFile)
+import Text.XML.Enumerator.Parse (parseBytes, decodeEntities)
+import Text.XML.Enumerator.Document (fromEvents)
+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
+import Data.Maybe
+
+import Data.XML.Types
+
+import Control.Monad.IO.Class (liftIO, MonadIO)
+import Data.String (IsString(..))
+
+isTLSSecured :: TLSState -> Bool
+isTLSSecured (PostHandshake _) = True
+isTLSSecured _ = False
+
+
+-- 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
+
+
+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 = "<presence" ++ from ++ id' ++ to ++ type' ++ ">" ++
+                  (elementsToString $ presencePayload p) ++ "</presence>"
+  where
+    from :: String
+    from = case presenceFrom p of
+      -- TODO: Lower-case
+      Just s -> " from='" ++ (show s) ++ "'"
+      Nothing -> ""
+
+    id' :: String
+    id' = case presenceID p of
+      Just (SID s) -> " id='" ++ s ++ "'"
+      Nothing -> ""
+
+    to :: String
+    to = case presenceTo p of
+      -- TODO: Lower-case
+      Just s -> " to='" ++ (show s) ++ "'"
+      Nothing -> ""
+
+    type' :: String
+    type' = case presenceType p of
+      Available -> ""
+      t -> " type='" ++ (presenceTypeToString t) ++ "'"
+
+iqToXML :: IQ -> String
+iqToXML (IQReq (IQGet { iqRequestID = i, iqRequestPayload = p, iqRequestFrom = f, iqRequestTo = t })) =
+  let type' = " type='get'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString (Just p)) ++ "</iq>"
+  where
+    from :: String
+    from = case f of
+      -- TODO: Lower-case
+      Just s -> " from='" ++ (show s) ++ "'"
+      Nothing -> ""
+
+    id' :: String
+    id' = case i of
+      Just (SID s) -> " id='" ++ s ++ "'"
+      Nothing -> ""
+
+    to :: String
+    to = case t of
+      -- TODO: Lower-case
+      Just s -> " to='" ++ (show s) ++ "'"
+      Nothing -> ""
+
+iqToXML (IQReq (IQSet { iqRequestID = i, iqRequestPayload = p, iqRequestFrom = f, iqRequestTo = t })) =
+  let type' = " type='set'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString (Just p)) ++ "</iq>"
+  where
+    from :: String
+    from = case f of
+      -- TODO: Lower-case
+      Just s -> " from='" ++ (show s) ++ "'"
+      Nothing -> ""
+
+    id' :: String
+    id' = case i of
+      Just (SID s) -> " id='" ++ s ++ "'"
+      Nothing -> ""
+
+    to :: String
+    to = case t of
+      -- TODO: Lower-case
+      Just s -> " to='" ++ (show s) ++ "'"
+      Nothing -> ""
+
+iqToXML (IQRes (IQResult { iqResponseID = i, iqResponsePayload = p, iqResponseFrom = f, iqResponseTo = t })) =
+  let type' = " type='result'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString p) ++ "</iq>"
+  where
+    from :: String
+    from = case f of
+      -- TODO: Lower-case
+      Just s -> " from='" ++ (show s) ++ "'"
+      Nothing -> ""
+
+    id' :: String
+    id' = case i of
+      Just (SID s) -> " id='" ++ s ++ "'"
+      Nothing -> ""
+
+    to :: String
+    to = case t of
+      -- TODO: Lower-case
+      Just s -> " to='" ++ (show s) ++ "'"
+      Nothing -> ""
+
+-- TODO: Turn message errors into XML.
+
+messageToXML :: Message -> String
+messageToXML Message { messageID = i, messageFrom = f, messageTo = t, messagePayload = p, messageType = ty } = "<message" ++ from ++ id' ++ to ++ type' ++ ">" ++
+                  (elementsToString $ p) ++ "</message>"
+  where
+    from :: String
+    from = case f of
+      -- TODO: Lower-case
+      Just s -> " from='" ++ (show s) ++ "'"
+      Nothing -> ""
+
+    id' :: String
+    id' = case i of
+      Just (SID s) -> " id='" ++ s ++ "'"
+      Nothing -> ""
+
+    to :: String
+    to = case t of
+      -- TODO: Lower-case
+      Just s -> " to='" ++ (show s) ++ "'"
+      Nothing -> ""
+
+    type' :: String
+    type' = case ty of
+      Normal -> ""
+      t -> " type='" ++ (messageTypeToString t) ++ "'"
+
+
+parseIQ :: Element -> IQ
+parseIQ e | typeAttr == "get" = let (Just payloadMust) = payload
+                                in IQReq (IQGet idAttr fromAttr toAttr Nothing
+                                   payloadMust)
+          | typeAttr == "set" = let (Just payloadMust) = payload
+                                in IQReq (IQSet idAttr fromAttr toAttr Nothing
+                                   payloadMust)
+          | typeAttr == "result" = IQRes (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 Address
+    fromAttr = case attributeText fromName e of
+      Nothing -> Nothing
+      Just a -> X.fromString $ DT.unpack a
+
+    toAttr :: Maybe Address
+    toAttr = case attributeText toName e of
+      Nothing -> Nothing
+      Just a -> X.fromString $ 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 Address
+    fromAttr = case attributeText fromName e of
+      Nothing -> Nothing
+      Just a -> X.fromString $ DT.unpack a
+
+    toAttr :: Maybe Address
+    toAttr = case attributeText toName e of
+      Nothing -> Nothing
+      Just a -> X.fromString $ 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 Address
+    fromAttr = case attributeText fromName e of
+      Nothing -> Nothing
+      Just a -> X.fromString $ DT.unpack a
+
+    toAttr :: Maybe Address
+    toAttr = case attributeText toName e of
+      Nothing -> Nothing
+      Just a -> X.fromString $ 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 "available" = Available -- TODO: Some client sent this
+
+stringToPresenceType "probe" = Probe
+-- stringToPresenceType "error" = PresenceError -- TODO: Special case
+
+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" -- TODO: Special case
+
+presenceTypeToString Subscribe = "subscribe"
+presenceTypeToString Subscribed = "subscribed"
+presenceTypeToString Unsubscribe = "unsubscribe"
+presenceTypeToString Unsubscribed = "unsubscribed"
+
+stringToMessageType "chat" = Chat
+stringToMessageType "error" = Error
+stringToMessageType "groupchat" = Groupchat
+stringToMessageType "headline" = Headline
+stringToMessageType "normal" = Normal
+stringToMessageType s = OtherMessageType s
+
+messageTypeToString Chat = "chat"
+messageTypeToString Error = "error"
+messageTypeToString Groupchat = "groupchat"
+messageTypeToString Headline = "headline"
+messageTypeToString Normal = "normal"
+messageTypeToString (OtherMessageType s) = s

Network/XMPP/TLS.hs

@@ -0,0 +1,47 @@
+-----------------------------------------------------------------------------
+--
+-- Module      :  Network.XMPP.TLS
+-- Copyright   :  Copyright © 2011, Jon Kristensen
+-- License     :  LGPL (Just (Version {versionBranch = [3], versionTags = []}))
+--
+-- Maintainer  :  jon.kristensen@pontarius.org
+-- Stability   :  alpha
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Network.XMPP.TLS (
+getTLSParams,
+handshake'
+) where
+
+import Network.TLS
+import Network.TLS.Cipher
+import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput)
+
+
+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

Network/XMPP/Types.hs

@@ -0,0 +1,457 @@
+-----------------------------------------------------------------------------
+--
+-- Module      :  Types
+-- Copyright   :  Copyright © 2011, Jon Kristensen
+-- License     :  LGPL (Just (Version {versionBranch = [3], versionTags = []}))
+--
+-- Maintainer  :  jon.kristensen@pontarius.org
+-- Stability   :  alpha
+-- Portability :
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+module Network.XMPP.Types (
+StanzaID (..),
+From,
+To,
+IQ (..),
+IQRequest (..),
+IQResponse (..),
+Message (..),
+MessageType (..),
+Presence (..),
+PresenceType (..),
+StanzaError (..),
+StanzaErrorType (..),
+StanzaErrorCondition (..),
+                            HostName
+                            , Password
+                            , PortNumber
+                            , Resource
+                            , UserName,
+EnumeratorEvent (..),
+Challenge (..),
+Success (..),
+TLSState (..),
+Address (..),
+Localpart,
+Serverpart,
+Resourcepart,
+XMLLang,
+InternalEvent (..),
+XMLEvent (..),
+ConnectionState (..),
+ClientEvent (..),
+StreamState (..),
+AuthenticationState (..),
+Certificate,
+ConnectResult (..),
+OpenStreamResult (..),
+SecureWithTLSResult (..),
+AuthenticateResult (..),
+ServerAddress (..),
+XMPPError (..),
+Timeout,
+TimeoutEvent (..),
+StreamError (..),
+IDGenerator (..)
+) where
+
+import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput)
+
+import qualified Network as N
+
+import qualified Control.Exception as CE
+
+import Control.Monad.State hiding (State)
+
+import Data.XML.Types
+
+import Network.TLS
+import Network.TLS.Cipher
+
+import qualified Control.Monad.Error as CME
+
+import Data.IORef
+
+
+
+-- =============================================================================
+--  STANZA TYPES
+-- =============================================================================
+
+
+-- TODO: Would a Stanza class such as the one below be useful sometimes?
+--
+-- class Stanza a where
+--     stanzaID :: a -> Maybe StanzaID
+--     stanzaFrom :: a -> Maybe From
+--     stanzaTo :: a -> Maybe To
+--     stanzaXMLLang :: a -> Maybe XMLLang
+
+
+-- |
+-- The StanzaID type wraps a string of random characters that in Pontarius XMPP
+-- is guaranteed to be unique for the XMPP session. Clients can add a string
+-- prefix for the IDs to guarantee that they are unique in a larger context by
+-- specifying the stanzaIDPrefix setting. TODO
+
+data StanzaID = SID String deriving (Eq, Show)
+
+
+-- |
+-- @From@ is a readability type synonym for @Address@.
+
+type From = Address
+
+
+-- |
+-- @To@ is a readability type synonym for @Address@.
+
+type To = Address
+
+
+-- |
+-- An Info/Query (IQ) stanza is either of the type "request" ("get" or "set") or
+-- "response" ("result" or "error"). The @IQ@ type wraps these two sub-types.
+
+data IQ = IQReq IQRequest | IQRes IQResponse deriving (Eq, Show)
+
+
+-- |
+-- A "request" Info/Query (IQ) stanza is one with either "get" or "set" as type.
+-- They are guaranteed to always contain a payload.
+
+data IQRequest = IQGet { iqRequestID :: Maybe StanzaID
+                       , iqRequestFrom :: Maybe From
+                       , iqRequestTo :: Maybe To
+                       , iqRequestXMLLang :: Maybe XMLLang
+                       , iqRequestPayload :: Element } |
+                 IQSet { iqRequestID :: Maybe StanzaID
+                       , iqRequestFrom :: Maybe From
+                       , iqRequestTo :: Maybe To
+                       , iqRequestXMLLang :: Maybe XMLLang
+                       , iqRequestPayload :: Element }
+                 deriving (Eq, Show)
+
+
+-- |
+-- A "response" Info/Query (IQ) stanza is one with either "result" or "error" as
+-- type.
+
+data IQResponse = IQResult { iqResponseID :: Maybe StanzaID
+                           , iqResponseFrom :: Maybe From
+                           , iqResponseTo :: Maybe To
+                           , iqResponseXMLLang :: Maybe XMLLang
+                           , iqResponsePayload :: Maybe Element } |
+                  IQError { iqResponseID :: Maybe StanzaID
+                          , iqResponseFrom :: Maybe From
+                          , iqResponseTo :: Maybe To
+                          , iqResponseXMLLang :: Maybe XMLLang
+                          , iqResponsePayload :: Maybe Element
+                          , iqResponseStanzaError :: StanzaError }
+                  deriving (Eq, Show)
+
+
+-- |
+-- The message stanza - either a message or a message error.
+
+data Message = Message { messageID :: Maybe StanzaID
+                       , messageFrom :: Maybe From
+                       , messageTo :: Maybe To
+                       , messageXMLLang :: Maybe XMLLang
+                       , messageType :: MessageType
+                       , messagePayload :: [Element] } |
+               MessageError { messageID :: Maybe StanzaID
+                            , messageFrom :: Maybe From
+                            , messageTo :: Maybe To
+                            , messageXMLLang  :: Maybe XMLLang
+                            , messageErrorPayload :: Maybe [Element]
+                            , messageErrorStanzaError :: StanzaError }
+               deriving (Eq, Show)
+
+
+-- |
+-- @MessageType@ holds XMPP message types as defined in XMPP-IM. @Normal@ is the
+-- default message type.
+
+data MessageType = Chat |
+                   Error |
+                   Groupchat |
+                   Headline |
+                   Normal |
+                   OtherMessageType String deriving (Eq, Show)
+
+
+-- |
+-- The presence stanza - either a presence or a presence error.
+
+data Presence = Presence { presenceID :: Maybe StanzaID
+                         , presenceFrom :: Maybe From
+                         , presenceTo :: Maybe To
+                         , presenceXMLLang  :: Maybe XMLLang
+                         , presenceType :: PresenceType
+                         , presencePayload :: [Element] } |
+                PresenceError { presenceID :: Maybe StanzaID
+                              , presenceFrom :: Maybe From
+                              , presenceTo :: Maybe To
+                              , presenceXMLLang  :: Maybe XMLLang
+                              , presenceErrorPayload :: Maybe [Element]
+                              , presenceErrorStanzaError :: StanzaError }
+                deriving (Eq, Show)
+
+
+-- |
+-- @PresenceType@ holds XMPP presence types. When a presence type is not
+-- provided, we assign the @PresenceType@ value @Available@.
+
+data PresenceType = Subscribe    | -- ^ Sender wants to subscribe to presence
+                    Subscribed   | -- ^ Sender has approved the subscription
+                    Unsubscribe  | -- ^ Sender is unsubscribing from presence
+                    Unsubscribed | -- ^ Sender has denied or cancelled a
+                                   --   subscription
+                    Probe        | -- ^ Sender requests current presence;
+                                   --   should only be used by servers
+                    Available    | -- ^ Sender did not specify a type attribute
+                    Unavailable deriving (Eq, Show)
+
+
+-- |
+-- All stanzas (IQ, message, presence) can cause errors, which in the XMPP
+-- stream looks like <stanza-kind to='sender' type='error'>. These errors are
+-- wrapped in the @StanzaError@ type.
+
+data StanzaError = StanzaError { stanzaErrorType :: StanzaErrorType
+                               , stanzaErrorCondition :: StanzaErrorCondition
+                               , stanzaErrorText :: Maybe String
+                               , stanzaErrorApplicationSpecificCondition ::
+                                 Maybe Element } deriving (Eq, Show)
+
+
+-- |
+-- @StanzaError@s always have one of these types.
+
+data StanzaErrorType = Cancel   | -- ^ Error is unrecoverable - do not retry
+                       Continue | -- ^ Conditition was a warning - proceed
+                       Modify   | -- ^ Change the data and retry
+                       Auth     | -- ^ Provide credentials and retry
+                       Wait       -- ^ Error is temporary - wait and retry
+                       deriving (Eq, Show)
+
+
+-- |
+-- Stanza errors are accommodated with one of the error conditions listed below.
+
+data StanzaErrorCondition = BadRequest            | -- ^ Malformed XML
+                            Conflict              | -- ^ Resource or session
+                                                    --   with name already
+                                                    --   exists
+                            FeatureNotImplemented |
+                            Forbidden             | -- ^ Insufficient
+                                                    --   permissions
+                            Gone                  | -- ^ Entity can no longer
+                                                    --   be contacted at this
+                                                    --   address
+                            InternalServerError   |
+                            ItemNotFound          |
+                            JIDMalformed          |
+                            NotAcceptable         | -- ^ Does not meet policy
+                                                    --   criteria
+                            NotAllowed            | -- ^ No entity may perform
+                                                    --   this action
+                            NotAuthorized         | -- ^ Must provide proper
+                                                    --   credentials
+                            PaymentRequired       |
+                            RecipientUnavailable  | -- ^ Temporarily
+                                                    --   unavailable
+                            Redirect              | -- ^ Redirecting to other
+                                                    --   entity, usually
+                                                    --   temporarily
+                            RegistrationRequired  |
+                            RemoteServerNotFound  |
+                            RemoteServerTimeout   |
+                            ResourceConstraint    | -- ^ Entity lacks the
+                                                    --   necessary system
+                                                    --   resources
+                            ServiceUnavailable    |
+                            SubscriptionRequired  |
+                            UndefinedCondition    | -- ^ Application-specific
+                                                    --   condition
+                            UnexpectedRequest       -- ^ Badly timed request
+                            deriving (Eq, Show)
+
+
+
+-- =============================================================================
+--  OTHER STUFF
+-- =============================================================================
+
+
+instance Eq ConnectionState 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 XMPPError = UncaughtEvent deriving (Eq, Show)
+
+instance CME.Error XMPPError where
+  strMsg "UncaughtEvent" = UncaughtEvent
+
+
+-- | 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 (Address) resource identifier Strings.
+
+type Resource = String
+
+
+-- 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)
+
+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 | IET (TimeoutEvent s m) deriving (Show)
+
+data TimeoutEvent s m = TimeoutEvent StanzaID Timeout (StateT s m ())
+
+instance Show (TimeoutEvent s m) where
+    show (TimeoutEvent (SID i) t _) = "TimeoutEvent (ID: " ++ (show i) ++ ", timeout: " ++ (show t) ++ ")"
+
+
+data StreamState = PreStream |
+                   PreFeatures StreamProperties |
+                   PostFeatures StreamProperties StreamFeatures
+
+
+data AuthenticationState = NoAuthentication | AuthenticatingPreChallenge1 String String (Maybe Resource) | AuthenticatingPreChallenge2 String String (Maybe Resource) | AuthenticatingPreSuccess String String (Maybe Resource) | AuthenticatedUnbound String (Maybe Resource) | AuthenticatedBound String Resource
+
+
+-- 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 N.HostName PortNumber
+                       (OpenStreamResult -> StateT s m ()) |
+                       CESecureWithTLS Certificate (Certificate -> Bool)
+                       (SecureWithTLSResult -> StateT s m ()) |
+                       CEAuthenticate UserName Password (Maybe Resource)
+                       (AuthenticateResult -> StateT s m ()) |
+                       CEMessage Message (Maybe (Message -> StateT s m Bool)) (Maybe (Timeout, StateT s m ())) (Maybe (StreamError -> StateT s m ())) |
+                       CEPresence Presence (Maybe (Presence -> StateT s m Bool)) (Maybe (Timeout, StateT s m ())) (Maybe (StreamError -> StateT s m ())) |
+                       CEIQ IQ (Maybe (IQ -> StateT s m Bool)) (Maybe (Timeout, StateT s m ())) (Maybe (StreamError -> StateT s m ())) |
+                       CEAction (Maybe (StateT s m Bool)) (StateT s m ())
+
+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 s _ _ _) = "CEIQ"
+  show (CEMessage s _ _ _) = "CEMessage"
+  show (CEPresence s _ _ _) = "CEPresence"
+
+  show (CEAction _ _) = "CEAction"
+
+
+type StreamID = String
+
+data ConnectionState = Disconnected | Connected ServerAddress Handle
+
+data TLSState = NoTLS | PreProceed | PreHandshake | PostHandshake TLSCtx
+
+data Challenge = Chal String deriving (Show)
+
+data Success = Succ String deriving (Show)
+
+
+type StreamProperties = Float
+type StreamFeatures = String
+
+
+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 Certificate = String -- TODO
+
+-- Address is a data type that has to be constructed in this module using either
+-- address or stringToAddress.
+
+data Address = Address { localpart :: Maybe Localpart
+                       , serverpart :: Serverpart
+                       , resourcepart :: Maybe Resourcepart }
+                       deriving (Eq)
+
+instance Show Address where
+    show (Address { localpart = n, serverpart = s, resourcepart = r })
+        | n == Nothing && r == Nothing = s
+        | r == Nothing                 = let Just n' = n in n' ++ "@" ++ s
+        | n == Nothing                 = let Just r' = r in s ++ "/" ++ r'
+        | otherwise                    = let Just n' = n; Just r' = r
+                                         in n' ++ "@" ++ s ++ "/" ++ r'
+
+type Localpart = String
+type Serverpart = String
+type Resourcepart = String
+
+data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq)
+
+type Timeout = Int
+
+data StreamError = StreamError
+
+
+-- =============================================================================
+--  XML TYPES
+-- =============================================================================
+
+type XMLLang = String
+-- Validate, protect. See:
+-- http://tools.ietf.org/html/rfc6120#section-8.1.5
+-- http://www.w3.org/TR/2008/REC-xml-20081126/
+-- http://www.rfc-editor.org/rfc/bcp/bcp47.txt
+-- http://www.ietf.org/rfc/rfc1766.txt
+
+
+newtype IDGenerator = IDGenerator (IORef [String])

Network/XMPP/Utilities.hs

@@ -0,0 +1,93 @@
+{-
+
+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 <http://www.gnu.org/licenses/>.
+
+-}
+
+-- |
+-- Module:      $Header$
+-- Description: Utility functions for Pontarius XMPP; currently only random ID
+--              generation functions
+-- Copyright:   Copyright © 2010-2011 Jon Kristensen
+-- License:     LGPL-3
+--
+-- Maintainer:  info@pontarius.org
+-- Stability:   unstable
+-- Portability: portable
+--
+-- This module will be documented soon.
+
+-- TODO: Document this module
+-- TODO: Make is possible to customize characters
+-- TODO: Make it possible to customize length
+
+module Network.XMPP.Utilities ( elementToString
+                              , elementsToString ) where
+
+import Data.Word
+import Data.XML.Types
+import System.Crypto.Random
+import System.Random
+import qualified Data.ByteString as DB
+import qualified Data.Map as DM
+import qualified Data.Text as DT
+
+
+
+-- =============================================================================
+--  XML Utilities
+-- =============================================================================
+
+
+elementsToString :: [Element] -> String
+elementsToString [] = ""
+elementsToString (e:es) = (elementToString $ Just e) ++ elementsToString es
+
+elementToString :: Maybe Element -> String
+elementToString Nothing = ""
+elementToString (Just e) = "<" ++ nameToString (elementName e) ++ xmlns ++
+                           attributes (elementAttributes e) ++
+                           ">" ++ (nodesToString $ elementNodes e) ++ "</" ++
+                           nameToString (elementName e) ++ ">"
+  where
+    xmlns :: String
+    xmlns = case nameNamespace $ elementName e of
+      Nothing -> ""
+      Just t -> " xmlns='" ++ (DT.unpack t) ++ "'"
+
+    nameToString :: Name -> String
+    nameToString Name { nameLocalName = n, namePrefix = Nothing } = DT.unpack n
+    nameToString Name { nameLocalName = n, namePrefix = Just p } =
+      (DT.unpack p) ++ ":" ++ (DT.unpack n)
+
+    contentToString :: Content -> String
+    contentToString (ContentText t) = DT.unpack t
+    contentToString (ContentEntity t) = DT.unpack t
+
+    attributes :: [(Name, [Content])] -> String
+    attributes [] = ""
+    attributes ((n, c):t) = (" " ++ (nameToString n) ++ "='" ++
+                             concat (map contentToString c) ++ "'") ++
+                            attributes t
+
+    nodesToString :: [Node] -> String
+    nodesToString [] = ""
+    nodesToString ((NodeElement e):ns) = (elementToString $ Just e) ++
+                                         (nodesToString ns)
+    nodesToString ((NodeContent c):ns) = (contentToString c) ++
+                                         (nodesToString ns)

README

@@ -0,0 +1,22 @@
+Pontarius XMPP aims to be a secure and easy-to-use XMPP library for Haskell. We
+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
+  * Support for Info/Query, Presence and Message Stanzas
+  * Interoperable XML Parsing (Using enumerator, xml-enumerator and xml-types)
+
+Please 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. However, if you are interested to use Pontarius XMPP anyway, feel free
+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 and having the library support
+all of RFC 3920: XMPP Core.
+
+The next version, 0.1 Alpha 6, is scheduled to be released on the 6th of July.
+
+Look at the Pontarius web site <http://www.pontarius.org/> and the Pontarius
+XMPP Hackage page <http://hackage.haskell.org/package/pontarius-xmpp/> for more
+information.

Setup.hs

@@ -0,0 +1,3 @@
+import Distribution.Simple
+
+main = defaultMain

pontarius-xmpp.cabal

@@ -0,0 +1,69 @@
+Name:               pontarius-xmpp
+Version:            0.0.6.0
+Cabal-Version:      >= 1.6
+Build-Type:         Simple
+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/
+Bug-Reports:        mailto:info@pontarius.org
+-- Package-URL:
+Synopsis:           A prototyped and incomplete implementation of RFC 6120:
+                    XMPP: Core
+Description:        A work in progress of an implementation of RFC 6120: XMPP:
+                    Core, as well as RFC 6122: XMPP: Address Format and other
+                    depending standards. A new version of Pontarius XMPP is
+                    released every three weeks.
+Category:           Network
+Tested-With:        GHC ==7.0.2
+-- Data-Files:
+-- Data-Dir:
+-- Extra-Source-Files:
+-- Extra-Tmp-Files:
+
+Library
+  Exposed-Modules:   Network.XMPP, Network.XMPP.Address, Network.XMPP.SASL,
+                     Network.XMPP.Session, Network.XMPP.Stanza,
+                     Network.XMPP.Stream, Network.XMPP.TLS, Network.XMPP.Types,
+                     Network.XMPP.Utilities
+  Exposed:           True
+  Build-Depends:     base >= 2 && < 5, parsec, enumerator, crypto-api,
+                     base64-string, pureMD5, utf8-string, network, xml-types,
+                     text, transformers, bytestring, binary, random,
+                     xml-enumerator, tls ==0.4.1, containers, mtl, text-icu,
+                     stringprep, idna2008 ==0.0.1.0
+  -- Other-Modules:
+  -- HS-Source-Dirs:
+  -- Extensions:
+  -- Build-Tools:
+  -- Buildable:
+  -- GHC-Options:
+  -- GHC-Prof-Options:
+  -- Hugs-Options:
+  -- NHC98-Options:
+  -- Includes:
+  -- Install-Includes:
+  -- Include-Dirs:
+  -- C-Sources:
+  -- Extra-Libraries:
+  -- Extra-Lib-Dirs:
+  -- CC-Options:
+  -- LD-Options:
+  -- Pkgconfig-Depends:
+  -- Frameworks:
+
+Source-Repository head
+  Type:     darcs
+  -- Module:
+  Location: https://patch-tag.com/r/jonkri/pontarius-xmpp
+  -- Subdir:
+
+Source-Repository this
+  Type:     darcs
+  -- Module:
+  Location: https://patch-tag.com/r/jonkri/pontarius-xmpp
+  Tag:      0.0.6.0
+  -- Subdir: