pontarius-xmpp 0.0.4.0 → 0.0.5.0
raw patch · 17 files changed
+3583/−871 lines, 17 filesdep +mtl
Dependencies added: mtl
Files
- Documentation/Pontarius XMPP Manual.lyx +430/−0
- Documentation/Software Design Description for Pontarius XMPP 1.0.lyx +192/−0
- Documentation/Software Quality Assurance Plan for Pontarius XMPP 1.0.lyx +324/−0
- Documentation/Software Requirements Specification for Pontarius XMPP.lyx +1439/−0
- Examples/EchoClient.hs +18/−4
- Network/XMPP.hs +14/−8
- Network/XMPP/Extensions/XEP0030.hs +36/−0
- Network/XMPP/Extensions/XEP0115.hs +20/−0
- Network/XMPP/JID.hs +26/−33
- Network/XMPP/Session.hs +207/−681
- Network/XMPP/Stanza.hs +13/−124
- Network/XMPP/Stream.hs +456/−0
- Network/XMPP/TLS.hs +47/−0
- Network/XMPP/Types.hs +337/−0
- Network/XMPP/Utilities.hs +15/−14
- README +1/−1
- pontarius-xmpp.cabal +8/−6
+ Documentation/Pontarius XMPP Manual.lyx view
@@ -0,0 +1,430 @@+#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 (Second Draft)+\end_layout++\begin_layout Author+The Pontarius Project+\end_layout++\begin_layout Date+The 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+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+Sending stanzas+\end_layout++\begin_layout Standard+Sending messages and presence is trivial:+\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++ StateT s m ()+\end_layout++\begin_layout Plain Layout++sendPresence :: MonadIO m => Session s m -> Presence ->+\end_layout++\begin_layout Plain Layout++ StateT s m ()+\end_layout++\end_inset+++\end_layout++\begin_layout Standard+However, as Info/Query (IQ) get and set stanzas typically have a corresponding+ IQ result stanza, we offer a way to define the callback to be used for+ the IQ result immediately in the sendIQ function:+\end_layout++\begin_layout Standard+\begin_inset listings+inline false+status open++\begin_layout Plain Layout++sendIQ :: MonadIO m => Session s m -> IQ -> Maybe (IQ ->+\end_layout++\begin_layout Plain Layout++ StateT s m Bool) -> StateT s m ()+\end_layout++\end_inset+++\end_layout++\begin_layout Standard+The optional callback function is executed first with the resulting IQ,+ and its boolean return value signals whether or not the IQ result stanza+ should be blocked from being sent through the stack of client handlers.+\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 view
@@ -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 view
@@ -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
+ Documentation/Software Requirements Specification for Pontarius XMPP.lyx view
@@ -0,0 +1,1439 @@+#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+Software Requirements Specification for Pontarius XMPP 0.1 (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 Subsection+Purpose+\end_layout++\begin_layout Standard+The goal of this document is to clarify---for Pontarius+\begin_inset Foot+status open++\begin_layout Plain Layout+For more information about the Pontarius project, see http://www.pontarius.org/.+\end_layout++\end_inset++ developers, the XMPP community, and to some extent the Haskell community---what+ we are implementing.+ We hope that it will help us in the Pontarius project to keep track of+ functionality and requirements, provide a basis for scheduling, and help+ us with our validation and verification processes.+\end_layout++\begin_layout Subsection+Scope+\end_layout++\begin_layout Standard+Pontarius XMPP 0.1 will implement the client capabilities of RFC 6120: XMPP:+ Core and the depending specifications (such as RFC 6122: XMPP: Address+ Format), as well as be easily extendable for different XMPP extensions+ (such as XEPs and RFCs).+\end_layout++\begin_layout Standard+We are planning to include support for XMPP server components later on,+ but we have currently not planned to include any XMPP server functionality.+ Support for common extensions such as Instant Messaging, Data Forms, Service+ Discovery, etc.+ will +\emph on+not+\emph default+ be included in the 0.1 version, but will be added in later (+\begin_inset Quotes eld+\end_inset++0.x+\begin_inset Quotes erd+\end_inset++) versions.+\end_layout++\begin_layout Standard+While it is the goal of the Pontarius project to develop secure and privacy-awar+e +\begin_inset Quotes eld+\end_inset++personal cloud+\begin_inset Quotes erd+\end_inset++ solutions on top of Pontarius XMPP, we want Pontarius XMPP to be a general-purp+ose and de facto XMPP library for Haskell.+ We want it to be correct, flexible and efficient to work in, and we hope+ that the purely functional and type safe environment offered by Haskell+ will help us to deliver that.+\end_layout++\begin_layout Standard+We will not repeat the specifics of the requirements from the RFC 6120:+ XMPP Core specification or any other specifications in this document.+\end_layout++\begin_layout Subsection+Legal notice+\end_layout++\begin_layout Standard+Pontarius XMPP is a free and open source software project.+ +\begin_inset Quotes eld+\end_inset++The 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 requirements 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.+\end_layout++\begin_layout Subsection+Definitions, acronyms, and abbrevations+\end_layout++\begin_layout Description+JID JabberID: An address for XMPP entities+\end_layout++\begin_layout Description+Pontarius A free and open source software project that aims to produce XMPP-base+d, uncentralized, and privacy-aware software solutions+\end_layout++\begin_layout Description+REQ Requirement+\end_layout++\begin_layout Description+RFC Request for Comments: A memorandum published by the Internet Engineering+ Task Force; some of these, including XMPP: Core and XMPP: Address Format,+ are published as Internet standards+\end_layout++\begin_layout Description+TCP Transmission Control Protocol: A reliable network transport protocol+\end_layout++\begin_layout Description+TLS Transport Layer Security: A secure network protocol, a successor to+ Secure Sockets Layer (SSL)+\end_layout++\begin_layout Description+XMPP Extendable Messaging and Presence Protocol: An uncentralized, open,+ and near-real-time presence and messaging protocol+\end_layout++\begin_layout Subsection+References+\end_layout++\begin_layout Itemize+Extensible Messaging and Presence Protocol (XMPP): Core, RFC 6120, March+ 2011, Internet Engineering Task Force+\end_layout++\begin_layout Itemize+Extensible Messaging and Presence Protocol (XMPP): Address Format, RFC 6122,+ March 2011, Internet Engineering Task Force+\end_layout++\begin_layout Subsection+Overview+\end_layout++\begin_layout Standard+The second section provides an overall description of the requirements of+ Pontarius XMPP 0.1, going through the features in a non-strict fashion,+ talking shortly about the product functions, as well as some constraints+ and assumptions.+\end_layout++\begin_layout Standard+The third section simply lists the requirements, categorized by external+ interfaces, functions, performance requirements, design constraints, and+ software system (quality) attributes.+\end_layout++\begin_layout Section+Overall Description+\end_layout++\begin_layout Subsection+Product perspective+\end_layout++\begin_layout Standard+Pontarius XMPP 0.1 will be used by XMPP clients to manage presence and messaging+ in a uncentralized near-real-time environments.+ For this first milestone of the library, we have chosen to implement only+ the XMPP: Core specification, and only the client capabilities of it.+ The reason for this is that we want to get the library out quickly, and+ want to have the core functionality of the library particularly well tested.+ The X in XMPP stands for extendable, and Pontarius XMPP must be flexible+ in regards for extensions, such as RFCs and XEPs; we might end up implementing+ hundreds of them.+ This is one of the most important quality attribute of the software.+\end_layout++\begin_layout Standard+Pontarius XMPP 0.1 is primarly designed to be used with Haskell, but we will+ develop C bindings for the library as well.+ The amount of C developers and APIs are huge, and making a C port will+ likely open up for other ports, probably more-so than any other language.+ Furthermore, the primary language for accessing GNOME is C.+\end_layout++\begin_layout Standard+Pontarius XMPP 0.1 must work on GNU/Linux, the main Free Software operating+ system.+ However, due to the platform support and high-level nature of Haskell,+ running it on other common operating systems is likely to work as well.+\end_layout++\begin_layout Standard+Pontarius XMPP 0.1 must work with the (estimated) most popular free and open+ source software XMPP server.+\end_layout++\begin_layout Standard+The only software using Pontarius XMPP (that we know of) is the Pontarius+ XPMN library, which currently in (very early) development.+ However, as mentioned above, the goal for Pontarius XMPP is to serve as+ a general-purpose library, so we are trying not to be customizing the library+ to be somehow specially tailored for Pontarius XPMN.+\end_layout++\begin_layout Standard+Pontarius XMPP 0.1 depends on the below (free and open source software) Haskell+ packages.+ I have omitted specification number [...] and source, as they are all available+ on Hackage.+\end_layout++\begin_layout Standard+\begin_inset space \space{}+\end_inset+++\end_layout++\begin_layout Standard+\begin_inset Tabular+<lyxtabular version="3" rows="20" columns="3">+<features tabularvalignment="middle">+<column alignment="center" valignment="top" width="0">+<column alignment="center" valignment="top" width="0">+<column alignment="center" valignment="top" width="0">+<row>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+Name (Mnemonic)+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+Version Number+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+Purpose+\end_layout++\end_inset+</cell>+</row>+<row>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+base+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+</row>+<row>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+base64-string+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+</row>+<row>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+binary+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+</row>+<row>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+bytestring+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+</row>+<row>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+containers+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+</row>+<row>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+crypto-api+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+</row>+<row>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+enumerator+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+</row>+<row>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+hslogger+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+</row>+<row>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+network+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+</row>+<row>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+pureMD5+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+</row>+<row>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+QuickCheck+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+</row>+<row>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+random+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+</row>+<row>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+regex-posix+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+</row>+<row>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+text+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+</row>+<row>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+tls+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+0.4.1+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+</row>+<row>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+transformers+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+</row>+<row>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+utf8-string+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+</row>+<row>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+xml-enumerator+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+</row>+<row>+<cell alignment="center" valignment="top" topline="true" bottomline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+xml-types+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" bottomline="true" leftline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+<cell alignment="center" valignment="top" topline="true" bottomline="true" leftline="true" rightline="true" usebox="none">+\begin_inset Text++\begin_layout Plain Layout+N/A+\end_layout++\end_inset+</cell>+</row>+</lyxtabular>++\end_inset+++\end_layout++\begin_layout Standard+\begin_inset space \space{}+\end_inset+++\end_layout++\begin_layout Standard+Every Pontarius XMPP 0.1 client will open up at most one TCP port on the+ system.+ Pontarius XMPP in itself does not write anything to the file system storage+ of the operating system, with the exception of the optional logging facility,+ disabled by default, which may be configured to write to disk.+\end_layout++\begin_layout Standard+Pontarius XMPP 0.1 will not provide any spam protection.+ However, we will utilize +\emph on+at least+\emph default+ Transport Layer Security to help protect clients using the library from+ attacks.+\end_layout++\begin_layout Standard+As we expect a very limited amount of concurrent XMPP clients, and a (relatively+) limited actitivity over XMPP streams--even when they are being fully active--w+e are not specifying any detailed memory or (process) performance requirements+ for Pontarius XMPP 0.1.+ However, we will stress test the library.+\end_layout++\begin_layout Standard+We see no hardware or user interfaces to take into account.+\end_layout++\begin_layout Subsection+Product functions+\end_layout++\begin_layout Standard+Pontarius XMPP 0.1 implements XMPP: Core and allow clients to do roughly+ the following: Open a TCP connection to a server, exchange XML information+ with the server to configure the (XML) stream, handle stream errors and+ encoding issues, have the connection secured by TLS, authenticate using+ a SASL mechanism and binding a resource to the stream, as well as sending+ and receiving so-called XMPP stanzas, certain +\begin_inset Quotes eld+\end_inset++top level+\begin_inset Quotes erd+\end_inset++ XML elements in the stream for communicating messages and presence.+\end_layout++\begin_layout Subsection+User characteristics+\end_layout++\begin_layout Standard+We expect developers using Pontarius XMPP 0.1 to understand the XMPP: Core+ specification, Haskell, and monads, including the StateT monad transformer.+\end_layout++\begin_layout Subsection+Constraints+\end_layout++\begin_layout Standard+In addition to the requirements in XMPP: Core, XMPP applications should+ be reliable in that they should be able to be online for a long period+ of time, without problems of memory leaks, unnecessary CPU usage, or similar,+ arising.+ Passwords should not be saved in memory unnecessarily for an extended period+ of time.+\end_layout++\begin_layout Subsection+Assumptions and dependencies+\end_layout++\begin_layout Standard+We assume that the Glasgow Haskell Compiler (GHC) is available on the system+ where Pontarius XMPP 0.1 runs.+\end_layout++\begin_layout Section+Specific requirements+\end_layout++\begin_layout Subsection+External interfaces+\end_layout++\begin_layout Standard+The software is accessible from Haskell and may be configured to do logging.+\end_layout++\begin_layout Description+REQ-1 The system shall be importable and fully functional from Haskell through+ a full import of the Network.XMPP namespace.+\end_layout++\begin_layout Description+REQ-2 The system shall be able to log information through arbitrary and+ flexible log handlers.+\end_layout++\begin_layout Description+REQ-3 The system shall run under GNU/Linux.+\end_layout++\begin_layout Description+REQ-4 The system shall work against the (estimated) most popular free and+ open source software XMPP server.+\end_layout++\begin_layout Subsection+Functions+\end_layout++\begin_layout Standard+If an error arises due to a bug in the software, the system shall throw+ a runtime exception and the process should exit.+ If an +\begin_inset Quotes eld+\end_inset++acceptable+\begin_inset Quotes erd+\end_inset++ exception is possible to arise, such as the XMPP server times out, then+ the related functions should reflect that by being able to return values+ such as Nothing or null.+ This allows the XMPP clients to take the appropriate actions.+\end_layout++\begin_layout Description+REQ-5 The system shall be validating input from all functions exposed through+ any of the system's APIs.+ +\end_layout++\begin_layout Description+REQ-6 Each incoming stanza should move through a stack of (client) handlers,+ where each handler may block the stanza from being delivered to handlers+ further up in the stack.+ The exceptions to this rule is stanza errors and IQ result stanzas, which+ may be delivered directly to a callback provided when generating the stanza+ (and possibly surpressed there).+\end_layout++\begin_layout Standard+Rationale: We have so far found it useful to stack XMPP client handlers+ on top of each other, letting them all manage their particular responsibilities+ and surpress their messages to handlers further up the stack.+\end_layout++\begin_layout Description+REQ-7 When the client is disconnected, a +\begin_inset Quotes eld+\end_inset++disconnect event+\begin_inset Quotes erd+\end_inset++ is generated in a way similar to in REQ-5.+ It is moved through the stack handlers; however, these events move down+ the stacks completely and can't be surpressed.+ The same thing applies for incoming stream errors, which can either be+ recoverable or unrecoverable.+ (?)+\end_layout++\begin_layout Standard+Rationale: We want the handlers to all do the appropriate clean-up activities.+\end_layout++\begin_layout Description+REQ-8 The API shall allow for opening a stream to a given IP or host name+ on a given port, returning either a success value or the reason for failing.+\end_layout++\begin_layout Description+REQ-9 The API shall allow for securing an opened stream with TLS, returning+ either a success value or the reason for failing.+\end_layout++\begin_layout Description+REQ-10 The API shall allow for authenticating an opened (possibly TLS secured)+ stream, returning either a success value of the reason for failing.+ If the credentials were wrong, the system shall allow the client to make+ as many retries as allowed by the server, without restarting the stream.+ Resource binding should be taken cared of in this step, and the client+ should be able to try to set a resource as well as have one generated by+ the server.+\end_layout++\begin_layout Standard+Rationale: Even though most clients wants to do REQ-9, REQ-10, and REQ-11+ in one action, some uses of XMPP (such as In-Band Registration) demands+ more flexibility.+\end_layout++\begin_layout Description+REQ-11 The API shall provide a convenience function for opening a stream,+ securing the stream with TLS, and authenticating an XMPP account in one+ function call, returning either a success value or the reason for failing.+\end_layout++\begin_layout Standard+Rationale: This makes the library easier and more efficient to use for most+ uses cases.+\end_layout++\begin_layout Description+REQ-12 The API shall provide the possibility for clients to close the stream.+\end_layout++\begin_layout Description+REQ-13 The API shall provide the possibility for clients to send stream+ errors.+\end_layout++\begin_layout Description+REQ-14 The API shall allow a convenient way for +\begin_inset Quotes eld+\end_inset++standard disconnect+\begin_inset Quotes erd+\end_inset++ the client.+\end_layout++\begin_layout Description+REQ-15 The API shall provide a facility for convenient stanza (message,+ presence, info/query) creation, eliminating the risk of illegal stanzas+ where feasible.+\end_layout++\begin_layout Description+REQ-16 The API shall allow for convenient construction of JabberIDs.+\end_layout++\begin_layout Description+REQ-17 The API shall provide utility functions to check whether or not a+ JID is full or bare.+\end_layout++\begin_layout Description+REQ-18 The API shall provide conversion functions to convert from a string+ to (+\begin_inset Quotes eld+\end_inset++Maybe+\begin_inset Quotes erd+\end_inset++) JID, and JID to string.+\end_layout++\begin_layout Description+REQ-19 The API shall provide an optional way for clients to receive time-out+ events on requests made, such as an IQ or connection attempt.+ The time-out interval should be customizable.+\end_layout++\begin_layout Subsection+Performance requirements+\end_layout++\begin_layout Standard+There is only one XMPP client per instance of the system.+\end_layout++\begin_layout Description+REQ-20 Regular desktop computers should be able to run hundreds of Pontarius+ XMPP 0.1 clients.+\end_layout++\begin_layout Description+REQ-21 Pontarius XMPP 0.1 should support virtually as many stanzas per second+ as (non-throttled) XMPP servers are able to route.+ This goes for both lightweight, heavy and mixed stanzas.+\end_layout++\begin_layout Description+REQ-22 Processing (parsing, generating, and firing the event) a received+ stanza should take at most 0.01 seconds.+\end_layout++\begin_layout Subsection+Design constraints+\end_layout++\begin_layout Subsubsection+RFC 6120: XMPP: Core+\end_layout++\begin_layout Description+REQ-23 The system shall support one persistant TCP stream/connection between+ the XMPP client and the XMPP server.+\end_layout++\begin_layout Description+REQ-24 The system shall determine the proper IPv4 or IPv6 address of the+ XMPP server, using the SRV Lookup process as explained in the 3.2.1 section+ of XMPP: Core, the fallback process defined i 3.2.2, with the exception of+ the case explained in 3.2.3.+\end_layout++\begin_layout Description+REQ-25 The system shall try to reconnect after a disconnection with a random+ delay between 0 and 60 seconds.+\end_layout++\begin_layout Description+REQ-26 The system shall try to reconnect with increased delays, in accordance+ with the +\begin_inset Quotes eld+\end_inset++truncated binary exponential backoff+\begin_inset Quotes erd+\end_inset+++\begin_inset Foot+status open++\begin_layout Plain Layout+See the "Information technology - Telecommunications and information exchange+ between systems - Local and metropolitan area networks - Specific requirements+ - Part 3: Carrier sense multiple access with collision detection (CSMA/CD)+ access method and physical layer specifications" section of IEEE Standard+ 802.3, September 1998.+\end_layout++\end_inset++, if the first reconnection attempt fails.+\end_layout++\begin_layout Description+REQ-27 The system shall make use of TLS session resumption when reconnecting+ to the server, if the connection was TLS secured.+\end_layout++\begin_layout Description+REQ-28 The system shall support stream management, as described in section+ 4 of XMPP: Core.+ This includes opening the stream, make the appropriate stream configurations+ (such as stream properties and features), parse incoming data, restart+ the stream when needed, determine the XMPP client's address, and properly+ close the stream.+\end_layout++\begin_layout Description+REQ-29 The system shall support securing the stream with TLS, as described+ in section 5 of XMPP: Core.+\end_layout++\begin_layout Description+REQ-30 The system shall support authenticating with SASL, as described in+ section 6 of XMPP: Core.+\end_layout++\begin_layout Description+REQ-31 Being a client library, the system shall support the 'jabber:client'+ namespace.+ The 'jabber:server' namespace shall be out of scope for the client.+ The client may use other namespaces if necessary, such as the ones for+ TLS and SASL.+\end_layout++\begin_layout Description+REQ-32 XML namespaces for stanzas should always be known to the client.+\end_layout++\begin_layout Description+REQ-33 The system shall always check for the appropriate features before+ trying to use them.+\end_layout++\begin_layout Description+REQ-34 The system shall support and utilize the +\begin_inset Quotes eld+\end_inset++whitespace keep-alive+\begin_inset Quotes erd+\end_inset++ mechanism to signal and verify that the TCP connection is alive.+\end_layout++\begin_layout Description+REQ-35 The system shall support a distributed network of clients and servers.+ Clients on one XMPP server should be able to communicate with server and+ clients on other networks.+\end_layout++\begin_layout Description+REQ-36 The system shall support the <presence/> primitive, a specialized+ +\begin_inset Quotes eld+\end_inset++publish-subscribe+\begin_inset Quotes erd+\end_inset++ mechanism for network availability.+ End-to-end presence or anything else presence-related defined outside of+ XMPP: Core (such as in XMPP: Instant Messaging) is +\emph on+not+\emph default+ supported.+\end_layout++\begin_layout Description+REQ-37 The system shall support the <message/> primitive, a +\begin_inset Quotes eld+\end_inset++push+\begin_inset Quotes erd+\end_inset++ mechanism.+\end_layout++\begin_layout Description+REQ-38 The system shall support the <iq/>, or Info/Query, primitive, a +\begin_inset Quotes eld+\end_inset++request-response+\begin_inset Quotes erd+\end_inset++ mechanism for exchanges of data.+\end_layout++\begin_layout Description+REQ-39 The system must offer timeout callbacks to be called if an asynchronous+ result is not guaranteed to be produced in a timely fashion.+\end_layout++\begin_layout Description+REQ-40 The system must a convenient API to deal with stanza and stream errors.+\end_layout++\begin_layout Subsubsection+RFC 6122: XMPP: Address Format+\end_layout++\begin_layout Description+REQ-41 JIDs should be validated in accordance with the standard.+\end_layout++\begin_layout Description+REQ-42 JIDs should support internationalization, as described in section+ 3 of the standard.+\end_layout++\begin_layout Description+REQ-43 Dealing with JIDs should adhere to the security recommendations as+ mentioned in section 4 of the standard.+\end_layout++\begin_layout Subsubsection+Standards compliance+\end_layout++\begin_layout Description+REQ-44 The project and its source code shall adhere to the guidelines prestented+ in the guidelines found at http://www.haskell.org/haskellwiki/Programming_guideli+nes.+\end_layout++\begin_layout Subsection+Software system attributes+\end_layout++\begin_layout Description+REQ-45 The system shall be +\emph on+extendable+\emph default+; it must be flexible in regards for extensions, such as RFCs and XEPs.+\end_layout++\begin_layout Description+REQ-46 The system shall be +\emph on+reliable+\emph default+; it should produce not crash, lag behind, or get some data corruption under+ very heavy and lengthy use.+\end_layout++\begin_layout Description+REQ-47 The system shall be +\emph on+secure+\emph default+; steps should be taken to protect the clients against man-in-the-middle+ attacks and the like.+\end_layout++\end_body+\end_document
Examples/EchoClient.hs view
@@ -24,6 +24,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} +module Examples.EchoClient () where+ import Network.XMPP import qualified Control.Monad as CM@@ -74,7 +76,7 @@ main :: IO () main = do- createSession+ session defaultState clientHandlers sessionCreated@@ -89,6 +91,16 @@ connect (DM.fromJust $ stateSession state) hostName portNumber (Just ("", \ x -> True)) (Just (userName, password, Just resource)) connectCallback+ 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 () @@ -101,7 +113,8 @@ case r of ConnectSuccess _ _ _ -> do sendPresence (DM.fromJust $ stateSession state)- (presence Nothing Nothing Nothing Nothing Available [])+ (presence Nothing Nothing Nothing Nothing Available []) Nothing Nothing+ Nothing _ -> do CMIC.liftIO $ putStrLn "Could not connect." return ()@@ -116,6 +129,7 @@ CMIC.liftIO $ putStrLn $ "Received a message; echoing it! By the way: Internal state is " ++ (show $ stateTest state) ++ "."- sendMessage (DM.fromJust $ stateSession state) $ message Nothing Nothing- (stanzaFrom $ messageStanza m) Nothing (messageType m) (messagePayload m)+ sendMessage (DM.fromJust $ stateSession state)+ (message Nothing Nothing (stanzaFrom $ messageStanza m) Nothing (messageType m) (messagePayload m))+ Nothing (Just (0, (do CMIC.liftIO $ putStrLn "Timeout!"; return ()))) Nothing return True
Network/XMPP.hs view
@@ -23,19 +23,19 @@ -- 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+-- 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@@ -45,10 +45,10 @@ , jidIsBare , stringToJID , jidToString- + -- Network.XMPP.SASL , replyToChallenge1- + -- Network.XMPP.Session , Certificate , ClientHandler (..)@@ -68,11 +68,11 @@ , openStream , secureWithTLS , authenticate- , createSession+ , session , OpenStreamResult (..) , SecureWithTLSResult (..) , AuthenticateResult (..)- + -- Network.XMPP.Stanza , StanzaID (SID) , From@@ -95,6 +95,8 @@ , getId , iqAck + , injectAction+ -- Network.XMPP.Utilities , elementToString , elementsToString@@ -106,3 +108,7 @@ 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/Extensions/XEP0030.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE MultiParamTypeClasses #-}++module Network.XMPP.Extensions.XEP0030 (+Feature (..),+Identity (..),+ServiceDiscoveryEntity (..),+serviceDiscoveryHandler,+serviceDiscoveryQuery+) where++import Network.XMPP.Session+import Network.XMPP.Types++import Control.Monad.State (StateT)+import Control.Monad.IO.Class (liftIO, MonadIO)++data Feature = Feature { featureVar :: XMLString }++data Identity = Identity { identityCategory :: XMLString+ , identityName :: Maybe XMLString+ , identityType :: XMLString }++class (ClientState s m, MonadIO m) => ServiceDiscoveryEntity s m where+ getFeatures :: JID -> StateT s m [Feature]+ getIdentities :: JID -> StateT s m [Identity]++serviceDiscoveryHandler :: (ClientState s m, MonadIO m,+ ServiceDiscoveryEntity s m) => ClientHandler s m++serviceDiscoveryHandler = serviceDiscoveryHandler++serviceDiscoveryQuery :: (ClientState s m, MonadIO m) => Session s m -> JID ->+ StateT s m ([Feature], [Identity]) -> Maybe (Timeout, StateT s m ()) ->+ Maybe (Either StreamError IQ) -> StateT s m ()++serviceDiscoveryQuery = serviceDiscoveryQuery
+ Network/XMPP/Extensions/XEP0115.hs view
@@ -0,0 +1,20 @@+-----------------------------------------------------------------------------+--+-- Module : Network.XMPP.Extensions.XEP0115+-- Copyright : Copyright © 2011, Jon Kristensen+-- License : LGPL (Just (Version {versionBranch = [3], versionTags = []}))+--+-- Maintainer : jon.kristensen@pontarius.org+-- Stability : alpha+-- Portability : +--+-- |+--+-----------------------------------------------------------------------------++module Network.XMPP.Extensions.XEP0115 (++) where+++
Network/XMPP/JID.hs view
@@ -19,29 +19,29 @@ -} --- | Module: $Header$--- Description: JabberID (JID) data type and utility functions--- Copyright: Copyright © 2010-2011 Jon Kristensen--- License: LGPL-3--- --- Maintainer: info@pontarius.org--- Stability: unstable--- Portability: portable--- --- JIDs are written in the format of `node@server/resource'. An example of a--- JID is `jonkri@jabber.org'.--- --- The node identifier is the part before the `@' character in Jabber IDs.--- Node names are optional. The server identifier is the part after the `@'--- character in Jabber IDs (and before the `/' character). The server--- identifier is the only required field of a JID. The server identifier MAY--- be an IP address but SHOULD be a fully qualified domain name. The resource--- identifier is the part after the `/' character in Jabber IDs. Like with--- node names, the resource identifier is optional.--- --- A JID without a resource identifier (i.e. a JID in the form of--- `node@server') is called `bare JID'. A JID with a resource identifier is--- called `full JID'.+-- |+-- Module: $Header$+-- Description: JabberID (JID) data type and utility functions+-- Copyright: Copyright © 2010-2011 Jon Kristensen+-- License: LGPL-3+--+-- Maintainer: info@pontarius.org+-- Stability: unstable+-- Portability: portable+--+-- JIDs are written in the format of `node@server/resource'. An example of a JID+-- is `jonkri@jabber.org'.+--+-- The node identifier is the part before the `@' character in Jabber IDs. Node+-- names are optional. The server identifier is the part after the `@' character+-- in Jabber IDs (and before the `/' character). The server identifier is the+-- only required field of a JID. The server identifier MAY be an IP address but+-- SHOULD be a fully qualified domain name. The resource identifier is the part+-- after the `/' character in Jabber IDs. Like with node names, the resource+-- identifier is optional.+--+-- A JID without a resource identifier (i.e. a JID in the form of `node@server')+-- is called `bare JID'. A JID with a resource identifier is called `full JID'. -- Node identifiers MUST be formatted in such a way so that the Nodeprep profile -- (see RFC 3920: XMPP Core, Appendix A) of RFC 3454: Preparation of@@ -73,22 +73,15 @@ -- TODO: Use Perl regular expressions to use non-capturing groups with "(?:"? -- TODO: Validate the input in the jid and stringToJID functions. -module Network.XMPP.JID ( JID (jidNode, jidServer, jidResource)- , jid+module Network.XMPP.JID ( jid , jidIsFull , jidIsBare , stringToJID , jidToString ) where -import Text.Regex.Posix ((=~))----- JID is a data type that has to be constructed in this module using either jid--- or stringToJID.+import Network.XMPP.Types -data JID = JID { jidNode :: Maybe String- , jidServer :: String- , jidResource :: Maybe String } deriving (Eq, Show)+import Text.Regex.Posix ((=~)) -- | Simple function to construct a JID. We will add validation to this function
Network/XMPP/Session.hs view
@@ -19,54 +19,47 @@ -} --- | 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+-- 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 #-} --- TODO: Better functions and events for stanzas, IncomingIQ, OutgoingIQ, etc. (ClientSession, ClientStanza)---- TODO: IO function to do everything related to the handle, instead of just connecting.---- TODO: Enumerate in the same thread? Enumerate one element at the time, non-blocking?----- | This module provides the functions used by XMPP clients to manage their--- XMPP sessions.--- --- Working with Pontarius XMPP is mostly done asynchronously with callbacks;--- Pontarius XMPP "owns" the XMPP thread and carries the client state with it.--- A client consists of a list of client handlers to handle XMPP events. This--- is all set up through a @Session@ object, which a client can create by--- calling the (blocking) function @createSession@.--- --- The Pontarius XMPP functions operate in an arbitrary MonadIO monad.--- Typically, clients will use the IO monad.--- --- For more information, see the Pontarius XMPP Manual.+-- |+-- Module: $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 ( Certificate- , ClientHandler (..)+module Network.XMPP.Session ( ClientHandler (..) , ClientState (..) , ConnectResult (..)- , HostName- , Password- , PortNumber- , Resource , Session , TerminationReason- , UserName , OpenStreamResult (..) , SecureWithTLSResult (..) , AuthenticateResult (..)@@ -77,11 +70,15 @@ , openStream , secureWithTLS , authenticate- , createSession ) where+ , session+ , injectAction ) where import Network.XMPP.JID 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@@ -139,14 +136,14 @@ -- 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. @@ -158,55 +155,12 @@ StateT s m ()) } --- | Readability type for host name Strings.--type HostName = String -- This is defined in Network as well----- | Readability type for port number Integers.--type PortNumber = Integer -- We use N(etwork).PortID (PortNumber) internally----- | Readability type for user name Strings.--type UserName = String----- | Readability type for password Strings.--type Password = String----- | Readability type for (JID) resource identifier Strings.--type Resource = String-- -- | @TerminationReason@ contains information on why the XMPP session was -- terminated. data TerminationReason = WhateverReason -- TODO -type Certificate = String -- TODO--data ConnectResult = ConnectSuccess StreamProperties StreamFeatures (Maybe Resource) |- ConnectOpenStreamFailure |- ConnectSecureWithTLSFailure |- ConnectAuthenticateFailure--data OpenStreamResult = OpenStreamSuccess StreamProperties StreamFeatures |- OpenStreamFailure--data SecureWithTLSResult = SecureWithTLSSuccess StreamProperties StreamFeatures | SecureWithTLSFailure--data AuthenticateResult = AuthenticateSuccess StreamProperties StreamFeatures Resource | AuthenticateFailure--type StreamProperties = Float-type StreamFeatures = String-- -- | Creates an XMPP session. Blocks the current thread. The first parameter, -- @s@, is an arbitrary state that is defined by the client. This is the -- initial state, and it will be passed to the client (handlers) as XMPP@@ -225,13 +179,13 @@ -- the new state context), and stores the updated client state in s''. Finally, -- we launch the (main) state loop of Pontarius XMPP. -createSession :: (MonadIO m, ClientState s m) => s -> [ClientHandler s m] ->- (CMS.StateT s m ()) -> m ()+session :: (MonadIO m, ClientState s m) => s -> [ClientHandler s m] ->+ (CMS.StateT s m ()) -> m () -createSession s h c = do+session s h c = do threadID <- liftIO $ newEmptyMVar chan <- liftIO $ newChan- ((), clientState) <- runStateT c (putSession s $ session chan)+ ((), clientState) <- runStateT c (putSession s $ session_ chan) (result, _) <- runStateT (stateLoop chan) (defaultState chan threadID h clientState) case result of@@ -249,7 +203,7 @@ return () where -- session :: Chan (InternalEvent m s) -> Session m s -- TODO- session c = Session { sessionChannel = c }+ session_ c = Session { sessionChannel = c } defaultState :: (MonadIO m, ClientState s m) => Chan (InternalEvent s m) -> MVar ThreadId ->@@ -268,7 +222,10 @@ , stateResource = Nothing , stateShouldExit = False , stateThreadID = t- , stateIQCallbacks = [] }+ , statePresenceCallbacks = []+ , stateMessageCallbacks = []+ , stateIQCallbacks = []+ , stateTimeoutStanzaIDs = [] } connect :: MonadIO m => Session s m -> HostName -> PortNumber ->@@ -276,19 +233,6 @@ Maybe (UserName, Password, Maybe Resource) -> (ConnectResult -> StateT s m ()) -> StateT s m () --- data ConnectResult = ConnectSuccess StreamProperties StreamFeatures Resource |--- ConnectOpenStreamFailure |--- ConnectTLSSecureStreamFailure |--- ConnectAuthenticateFailure---- data OpenStreamResult = OpenStreamSuccess StreamProperties StreamFeatures |--- OpenStreamFailure---- data SecureWithTLSResult = SecureWithTLSSuccess StreamProperties StreamFeatures | SecureWithTLSFailure---- data AuthenticateResult = AuthenticateSuccess Resource | AuthenticateFailure-- connect s h p t a c = openStream s h p connect' where connect' r = case r of@@ -314,7 +258,7 @@ openStream s h p c = CMS.get >>= (\ state -> lift $ liftIO $ writeChan (sessionChannel s)- (IEC (CEOpenStream state h p c)))+ (IEC (CEOpenStream h p c))) secureWithTLS :: MonadIO m => Session s m -> Certificate ->@@ -324,7 +268,7 @@ secureWithTLS s c a c_ = CMS.get >>= (\ state -> lift $ liftIO $ writeChan (sessionChannel s)- (IEC (CESecureWithTLS state c a c_)))+ (IEC (CESecureWithTLS c a c_))) -- |@@ -336,26 +280,32 @@ authenticate s u p r c = CMS.get >>= (\ state -> lift $ liftIO $ writeChan (sessionChannel s)- (IEC (CEAuthenticate state u p r c)))+ (IEC (CEAuthenticate u p r c))) -sendMessage :: MonadIO m => Session s m -> Message -> StateT s m ()-sendMessage s m = CMS.get >>=+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 s)- (IEC (CEMessage state m)))+ writeChan (sessionChannel se)+ (IEC (CEMessage m c t st))) -sendPresence :: MonadIO m => Session s m -> Presence -> StateT s m ()-sendPresence s p = CMS.get >>=+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 s)- (IEC (CEPresence state p)))+ writeChan (sessionChannel se)+ (IEC (CEPresence p c t st))) -sendIQ :: MonadIO m => Session s m -> IQ -> Maybe (IQ -> StateT s m Bool) -> StateT s m ()-sendIQ s i c = CMS.get >>=+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 (CEIQ state i c)))+ (IEC (CEAction p a))) -- xmppDisconnect :: MonadIO m => Session s m -> Maybe (s -> (Bool, s)) -> m () -- xmppDisconnect s c = xmppDisconnect s c@@ -369,74 +319,6 @@ -- ============================================================================= -data XMPPError = UncaughtEvent deriving (Eq, Show)--instance CME.Error XMPPError where- strMsg "UncaughtEvent" = UncaughtEvent--type StreamID = String----- Client actions that needs to be performed in the (main) state loop are--- converted to ClientEvents and sent through the internal event channel.--data ClientEvent s m = CEOpenStream s N.HostName PortNumber- (OpenStreamResult -> StateT s m ()) |- CESecureWithTLS s Certificate (Certificate -> Bool)- (SecureWithTLSResult -> StateT s m ()) |- CEAuthenticate s UserName Password (Maybe Resource)- (AuthenticateResult -> StateT s m ()) |- CEMessage s Message |- CEPresence s Presence |- CEIQ s IQ (Maybe (IQ -> StateT s m Bool))--instance Show (ClientEvent s m) where- show (CEOpenStream _ h p _) = "CEOpenStream " ++ h ++ " " ++ (show p)- show (CESecureWithTLS _ c _ _) = "CESecureWithTLS " ++ c- show (CEAuthenticate _ u p r _) = "CEAuthenticate " ++ u ++ " " ++ p ++ " " ++- (show r)- show (CEIQ _ i (Just _)) = "CEIQ " ++ (show i) ++ " (with callback)"- show (CEIQ _ i Nothing) = "CEIQ " ++ (show i) ++ " (without callback)"- show (CEMessage _ m) = "CEMessage " ++ (show m)- show (CEPresence _ p) = "CEPresence " ++ (show p)----- An XMLEvent is triggered by an XML stanza or some other XML event, and is--- sent through the internal event channel, just like client action events.--data XMLEvent = XEBeginStream String | XEFeatures String |- XEChallenge Challenge | XESuccess Success |- XEEndStream | XEIQ IQ | XEPresence Presence |- XEMessage Message | XEProceed |- XEOther String deriving (Show)----- instance Eq ConnectionState where--- (==) Disconnected Disconnected = True--- (==) ConnectedNotTLSSecured ConnectedNotTLSSecured = True--- (==) (ConnectedTLSSecured _) (ConnectedTLSSecured _) = True--- (==) _ _ = False---data EnumeratorEvent = EnumeratorDone |- EnumeratorXML XMLEvent |- EnumeratorException CE.SomeException- deriving (Show)----- Type to contain the internal events.--data InternalEvent s m = IEC (ClientEvent s m) | IEE EnumeratorEvent deriving (Show)---data Challenge = Chal String deriving (Show)--data Success = Succ String deriving (Show)---data ConnectionState s m = Disconnected | Connected ServerAddress Handle-- type OpenStreamCallback s m = Maybe (OpenStreamResult -> CMS.StateT s m ()) type SecureWithTLSCallback s m = Maybe (SecureWithTLSResult -> CMS.StateT s m ())@@ -444,50 +326,28 @@ type AuthenticateCallback s m = Maybe (AuthenticateResult -> CMS.StateT s m ()) -data StreamState s m = PreStream |- PreFeatures StreamProperties |- PostFeatures StreamProperties StreamFeatures----data TLSState = NoTLS | PreProceed | PreHandshake | PostHandshake TLSCtx---isTLSSecured :: TLSState -> Bool-isTLSSecured (PostHandshake _) = True-isTLSSecured _ = False--data AuthenticationState s m = NoAuthentication | AuthenticatingPreChallenge1 String String (Maybe Resource) | AuthenticatingPreChallenge2 String String (Maybe Resource) | AuthenticatingPreSuccess String String (Maybe Resource) | AuthenticatedUnbound String (Maybe Resource) | AuthenticatedBound String Resource---isConnected :: ConnectionState s m -> Bool+isConnected :: ConnectionState -> Bool isConnected Disconnected = True isConnected (Connected _ _) = True -instance Eq (ConnectionState s m) where- Disconnected == Disconnected = True- (Connected p h) == (Connected p_ h_) = p == p_ && h == h_- -- (ConnectedPostFeatures s p h t) == (ConnectedPostFeatures s p h t) = True- -- (ConnectedAuthenticated s p h t) == (ConnectedAuthenticated s p h t) = True- _ == _ = False--data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq)- data MonadIO m => State s m = State { stateClientHandlers :: [ClientHandler s m] , stateClientState :: s , stateChannel :: Chan (InternalEvent s m)- , stateConnectionState :: ConnectionState s m+ , stateConnectionState :: ConnectionState -- s m , stateTLSState :: TLSState- , stateStreamState :: StreamState s m+ , stateStreamState :: StreamState , stateOpenStreamCallback :: OpenStreamCallback s m , stateSecureWithTLSCallback :: SecureWithTLSCallback s m , stateAuthenticateCallback :: AuthenticateCallback s m- , stateAuthenticationState :: AuthenticationState 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] } @@ -535,20 +395,20 @@ _ -> let Connected _ handle = stateConnectionState state in Left handle in case e of- + -- --------------------------------------------------------------------------- -- CLIENT EVENTS -- ---------------------------------------------------------------------------- -- - IEC (CEOpenStream clientState hostName portNumber callback) -> do- + --+ 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@@ -562,20 +422,21 @@ 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 clientState certificate verifyCertificate callback) -> do++ 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 clientState userName password resource callback) -> do+ IEC (CEAuthenticate userName password resource callback) -> do -- CEB.assert (or [ stateConnectionState state == Connected -- , stateConnectionState state == TLSSecured ]) (return ()) -- CEB.assert (stateHandle state /= Nothing) (return ())@@ -583,11 +444,11 @@ , 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@@ -607,9 +468,9 @@ return () r <- lift $ liftIO $ getID lift $ liftIO $ send ("<iq type=\"set\" id=\"" ++ r ++ "\"><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@@ -621,7 +482,7 @@ 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@@ -640,7 +501,7 @@ "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@@ -664,7 +525,7 @@ 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'?>?@@ -674,74 +535,109 @@ 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)) -> do+ IEE (EnumeratorXML (XEIQ iqEvent)) -> case shouldIgnoreIQ iqEvent of- True ->- return Nothing- False -> do- let iqReceivedFunctions = map (\ x -> iqReceived x) (stateClientHandlers state)- let functions = map (\ x -> case x of- Just f -> Just (f iqEvent)- Nothing -> Nothing) iqReceivedFunctions- let functions' = case lookup (fromJust $ stanzaID $ iqStanza $ iqEvent) (stateIQCallbacks state) of- Just f -> (Just (f iqEvent)):functions- Nothing -> functions- let clientState = stateClientState state -- ClientState s m- clientState' <- sendToClient functions' clientState- put $ state { stateClientState = clientState' }- return Nothing- + True ->+ return Nothing+ False -> do+ let stanzaID' = stanzaID $ iqStanza $ 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 $ stanzaID $ iqStanza $ 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' = stanzaID $ presenceStanza $ 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' }+ put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts } return Nothing- + IEE (EnumeratorXML (XEMessage messageEvent)) -> do+ let stanzaID' = stanzaID $ messageStanza $ 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' }+ put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts } return Nothing- - IEC (CEPresence clientState presence) -> do++ IEC (CEPresence presence stanzaCallback timeoutCallback streamErrorCallback) -> do presence' <- case stanzaID $ presenceStanza presence of Nothing -> do id <- lift $ liftIO $ getID return $ presence { presenceStanza = (presenceStanza presence) { stanzaID = Just (SID id) } } _ -> return presence+ case timeoutCallback of+ Just (t, timeoutCallback') ->+ let stanzaID' = (fromJust $ stanzaID $ presenceStanza 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 clientState message) -> do+ IEC (CEMessage message stanzaCallback timeoutCallback streamErrorCallback) -> do message' <- case stanzaID $ messageStanza message of Nothing -> do id <- lift $ liftIO $ getID return $ message { messageStanza = (messageStanza message) { stanzaID = Just (SID id) } } _ -> return message+ case timeoutCallback of+ Just (t, timeoutCallback') ->+ let stanzaID' = (fromJust $ stanzaID $ messageStanza 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 clientState iq callback) -> do++ IEC (CEIQ iq stanzaCallback timeoutCallback stanzaErrorCallback) -> do iq' <- case stanzaID $ iqStanza iq of Nothing -> do id <- lift $ liftIO $ getID@@ -753,21 +649,49 @@ IQResult {} -> do iq { iqResultStanza = (iqStanza iq) { stanzaID = Just (SID id) } } _ -> return iq- case callback of+ case stanzaCallback of Just callback' -> case iq of IQGet {} -> put $ state { stateIQCallbacks = (fromJust $ stanzaID $ iqStanza iq', callback'):(stateIQCallbacks state) } IQSet {} -> put $ state { stateIQCallbacks = (fromJust $ stanzaID $ iqStanza iq', callback'):(stateIQCallbacks state) } _ -> return () Nothing -> return ()+ case timeoutCallback of+ Just (t, timeoutCallback') ->+ let stanzaID' = (fromJust $ stanzaID $ iqStanza 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)@@ -793,6 +717,30 @@ 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@@ -801,425 +749,3 @@ case b of True -> return s' False -> sendToClient fs s'----- Reads from the provided handle or TLS context and sends the events to the--- internal event channel.--xmlEnumerator :: Chan (InternalEvent s m) -> Either Handle TLSCtx -> IO ()-xmlEnumerator c s = do- enumeratorResult <- case s of- Left handle -> run $ enumHandle 1 handle $$ joinI $- parseBytes decodeEntities $$ xmlReader c- Right tlsCtx -> run $ enumTLS tlsCtx $$ joinI $- parseBytes decodeEntities $$ xmlReader c- case enumeratorResult of- Right _ ->- writeChan c $ IEE EnumeratorDone- Left e ->- writeChan c $ IEE (EnumeratorException e)- where- -- Behaves like enumHandle, but reads from the TLS context instead- enumTLS :: TLSCtx -> E.Enumerator DB.ByteString IO b- enumTLS c s = loop c s- - loop :: TLSCtx -> E.Step DB.ByteString IO b -> E.Iteratee DB.ByteString IO b- loop c (E.Continue k) = do- d <- recvData c- case DBL.null d of- True -> loop c (E.Continue k)- False -> k (E.Chunks $ DBL.toChunks d) E.>>== loop c- loop _ step = E.returnI step---getTLSParams :: TLSParams-getTLSParams = TLSParams { pConnectVersion = TLS10- , pAllowedVersions = [TLS10,TLS11]- , pCiphers = [cipher_AES256_SHA1] -- Check the rest- , pCompressions = [nullCompression]- , pWantClientCert = False- , pCertificates = []- , onCertificatesRecv = \_ -> return True } -- Verify cert chain--handshake' :: Handle -> String -> IO (Maybe TLSCtx)-handshake' h s = do- let t = getTLSParams- r <- makeSRandomGen- case r of- Right sr -> do- putStrLn $ show sr- c <- client t sr h- handshake c- putStrLn ">>>>TLS data sended<<<<"- return (Just c)- Left ge -> do- putStrLn $ show ge- return Nothing---xmlReader :: Chan (InternalEvent s m) -> Iteratee Event IO (Maybe Event)--xmlReader c = xmlReader_ c [] 0---xmlReader_ :: Chan (InternalEvent s m) -> [Event] -> Int ->- Iteratee Event IO (Maybe Event)--xmlReader_ ch [EventBeginDocument] 0 = xmlReader_ ch [] 0---- TODO: Safe to start change level here? We are doing this since the stream can--- restart.--- TODO: l < 2?-xmlReader_ ch [EventBeginElement name attribs] l- | l < 3 && nameLocalName name == DT.pack "stream" &&- namePrefix name == Just (DT.pack "stream") = do- liftIO $ writeChan ch $ IEE $ EnumeratorXML $ XEBeginStream $ "StreamTODO"- xmlReader_ ch [] 1--xmlReader_ ch [EventEndElement name] 1- | namePrefix name == Just (DT.pack "stream") &&- nameLocalName name == DT.pack "stream" = do- liftIO $ writeChan ch $ IEE $ EnumeratorXML $ XEEndStream- return Nothing---- Check if counter is one to forward it to related function.--- Should replace "reverse ((EventEndElement n):es)" with es--- ...-xmlReader_ ch ((EventEndElement n):es) 1- | nameLocalName n == DT.pack "proceed" = do- liftIO $ writeChan ch $ IEE $ EnumeratorXML $ XEProceed- E.yield Nothing (E.Chunks [])- | otherwise = do- -- liftIO $ putStrLn "Got an IEX Event..."- liftIO $ writeChan ch $ IEE $ EnumeratorXML $ (processEventList (DL.reverse ((EventEndElement n):es)))- xmlReader_ ch [] 1---- Normal condition, buffer the event to events list.-xmlReader_ ch es co = do- head <- EL.head- let co' = counter co head- -- liftIO $ putStrLn $ show co' ++ "\t" ++ show head -- for test- case head of- Just e -> xmlReader_ ch (e:es) co'- Nothing -> xmlReader_ ch es co'----- TODO: Generate real event.-processEventList :: [Event] -> XMLEvent-processEventList e- | namePrefix name == Just (DT.pack "stream") &&- nameLocalName name == DT.pack "features" = XEFeatures "FeaturesTODO"- | nameLocalName name == DT.pack "challenge" =- let EventContent (ContentText c) = head es in XEChallenge $ Chal $ DT.unpack c- | nameLocalName name == DT.pack "success" =- let EventContent (ContentText c) = head es in XESuccess $ Succ $ "" -- DT.unpack c- | nameLocalName name == DT.pack "iq" = XEIQ $ parseIQ $ eventsToElement e- | nameLocalName name == DT.pack "presence" = XEPresence $ parsePresence $ eventsToElement e- | nameLocalName name == DT.pack "message" = XEMessage $ parseMessage $ eventsToElement e- | otherwise = XEOther $ elementToString $ Just (eventsToElement e)- where- (EventBeginElement name attribs) = head e- es = tail e--eventsToElement :: [Event] -> Element-eventsToElement e = do- documentRoot $ fromJust (run_ $ enum e $$ fromEvents)- where- enum :: [Event] -> E.Enumerator Event Maybe Document- enum e_ (E.Continue k) = k $ E.Chunks e_- enum e_ step = E.returnI step--counter :: Int -> Maybe Event -> Int-counter c (Just (EventBeginElement _ _)) = (c + 1)-counter c (Just (EventEndElement _) ) = (c - 1)-counter c _ = c--presenceToXML :: Presence -> String-presenceToXML p = "<presence" ++ from ++ id' ++ to ++ type' ++ ">" ++- (elementsToString $ presencePayload p) ++ "</presence>"- where- s = presenceStanza p- - from :: String- from = case stanzaFrom $ presenceStanza p of- -- TODO: Lower-case- Just s -> " from='" ++ (jidToString s) ++ "'"- Nothing -> ""- - id' :: String- id' = case stanzaID s of- Just (SID s) -> " id='" ++ s ++ "'"- Nothing -> ""- - to :: String- to = case stanzaTo $ presenceStanza p of- -- TODO: Lower-case- Just s -> " to='" ++ (jidToString s) ++ "'"- Nothing -> ""- - type' :: String- type' = case presenceType p of- Available -> ""- t -> " type='" ++ (presenceTypeToString t) ++ "'"--iqToXML :: IQ -> String-iqToXML IQGet { iqGetStanza = s, iqGetPayload = p } =- let type' = " type='get'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString (Just p)) ++ "</iq>"- where- from :: String- from = case stanzaFrom s of- -- TODO: Lower-case- Just s -> " from='" ++ (jidToString s) ++ "'"- Nothing -> ""- - id' :: String- id' = case stanzaID s of- Just (SID s) -> " id='" ++ s ++ "'"- Nothing -> ""- - to :: String- to = case stanzaTo s of- -- TODO: Lower-case- Just s -> " to='" ++ (jidToString s) ++ "'"- Nothing -> ""--iqToXML IQSet { iqSetStanza = s, iqSetPayload = p } =- let type' = " type='set'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString (Just p)) ++ "</iq>"- where- from :: String- from = case stanzaFrom s of- -- TODO: Lower-case- Just s -> " from='" ++ (jidToString s) ++ "'"- Nothing -> ""- - id' :: String- id' = case stanzaID s of- Just (SID s) -> " id='" ++ s ++ "'"- Nothing -> ""- - to :: String- to = case stanzaTo s of- -- TODO: Lower-case- Just s -> " to='" ++ (jidToString s) ++ "'"- Nothing -> ""--iqToXML IQResult { iqResultStanza = s, iqResultPayload = p } =- let type' = " type='result'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString p) ++ "</iq>"- where- from :: String- from = case stanzaFrom s of- -- TODO: Lower-case- Just s -> " from='" ++ (jidToString s) ++ "'"- Nothing -> ""- - id' :: String- id' = case stanzaID s of- Just (SID s) -> " id='" ++ s ++ "'"- Nothing -> ""- - to :: String- to = case stanzaTo s of- -- TODO: Lower-case- Just s -> " to='" ++ (jidToString s) ++ "'"- Nothing -> ""--messageToXML :: Message -> String-messageToXML m = "<message" ++ from ++ id' ++ to ++ type' ++ ">" ++- (elementsToString $ messagePayload m) ++ "</message>"- where- s = messageStanza m- - from :: String- from = case stanzaFrom $ messageStanza m of- -- TODO: Lower-case- Just s -> " from='" ++ (jidToString s) ++ "'"- Nothing -> ""- - id' :: String- id' = case stanzaID s of- Just (SID s) -> " id='" ++ s ++ "'"- Nothing -> ""- - to :: String- to = case stanzaTo $ messageStanza m of- -- TODO: Lower-case- Just s -> " to='" ++ (jidToString s) ++ "'"- Nothing -> ""- - type' :: String- type' = case messageType m of- Normal -> ""- t -> " type='" ++ (messageTypeToString t) ++ "'"---parseIQ :: Element -> IQ-parseIQ e | typeAttr == "get" = let (Just payloadMust) = payload- in iqGet idAttr fromAttr toAttr Nothing- payloadMust- | typeAttr == "set" = let (Just payloadMust) = payload- in iqSet idAttr fromAttr toAttr Nothing- payloadMust- | typeAttr == "result" = iqResult idAttr fromAttr toAttr Nothing- payload-- where- -- TODO: Many duplicate functions from parsePresence.- - payload :: Maybe Element- payload = case null (elementChildren e) of- True -> Nothing- False -> Just $ head $ elementChildren e- - typeAttr :: String- typeAttr = case attributeText typeName e of- -- Nothing -> Nothing- Just a -> DT.unpack a- - fromAttr :: Maybe JID- fromAttr = case attributeText fromName e of- Nothing -> Nothing- Just a -> stringToJID $ DT.unpack a- - toAttr :: Maybe JID- toAttr = case attributeText toName e of- Nothing -> Nothing- Just a -> stringToJID $ DT.unpack a- - idAttr :: Maybe StanzaID- idAttr = case attributeText idName e of- Nothing -> Nothing- Just a -> Just (SID (DT.unpack a))- - typeName :: Name- typeName = fromString "type"- - fromName :: Name- fromName = fromString "from"- - toName :: Name- toName = fromString "to"- - idName :: Name- idName = fromString "id"---- TODO: Parse xml:lang--parsePresence :: Element -> Presence-parsePresence e = presence idAttr fromAttr toAttr Nothing typeAttr (elementChildren e)- where- -- TODO: Many duplicate functions from parseIQ.- - typeAttr :: PresenceType- typeAttr = case attributeText typeName e of- Just t -> stringToPresenceType $ DT.unpack t- Nothing -> Available- - fromAttr :: Maybe JID- fromAttr = case attributeText fromName e of- Nothing -> Nothing- Just a -> stringToJID $ DT.unpack a- - toAttr :: Maybe JID- toAttr = case attributeText toName e of- Nothing -> Nothing- Just a -> stringToJID $ DT.unpack a- - idAttr :: Maybe StanzaID- idAttr = case attributeText idName e of- Nothing -> Nothing- Just a -> Just (SID (DT.unpack a))- - fromName :: Name- fromName = fromString "from"- - typeName :: Name- typeName = fromString "type"- - toName :: Name- toName = fromString "to"- - idName :: Name- idName = fromString "id"--parseMessage :: Element -> Message-parseMessage e = message idAttr fromAttr toAttr Nothing typeAttr (elementChildren e)- where- -- TODO: Many duplicate functions from parseIQ.- - typeAttr :: MessageType- typeAttr = case attributeText typeName e of- Just t -> stringToMessageType $ DT.unpack t- Nothing -> Normal- - fromAttr :: Maybe JID- fromAttr = case attributeText fromName e of- Nothing -> Nothing- Just a -> stringToJID $ DT.unpack a- - toAttr :: Maybe JID- toAttr = case attributeText toName e of- Nothing -> Nothing- Just a -> stringToJID $ DT.unpack a- - idAttr :: Maybe StanzaID- idAttr = case attributeText idName e of- Nothing -> Nothing- Just a -> Just (SID (DT.unpack a))- - fromName :: Name- fromName = fromString "from"- - typeName :: Name- typeName = fromString "type"- - toName :: Name- toName = fromString "to"- - idName :: Name- idName = fromString "id"---- stringToPresenceType "available" = Available--- stringToPresenceType "away" = Away--- stringToPresenceType "chat" = Chat--- stringToPresenceType "dnd" = DoNotDisturb--- stringToPresenceType "xa" = ExtendedAway--stringToPresenceType "probe" = Probe-stringToPresenceType "error" = PresenceError--stringToPresenceType "unavailable" = Unavailable-stringToPresenceType "subscribe" = Subscribe-stringToPresenceType "subscribed" = Subscribed-stringToPresenceType "unsubscribe" = Unsubscribe-stringToPresenceType "unsubscribed" = Unsubscribed---- presenceTypeToString Available = "available"---- presenceTypeToString Away = "away"--- presenceTypeToString Chat = "chat"--- presenceTypeToString DoNotDisturb = "dnd"--- presenceTypeToString ExtendedAway = "xa"--presenceTypeToString Unavailable = "unavailable"--presenceTypeToString Probe = "probe"-presenceTypeToString PresenceError = "error"--presenceTypeToString Subscribe = "subscribe"-presenceTypeToString Subscribed = "subscribed"-presenceTypeToString Unsubscribe = "unsubscribe"-presenceTypeToString Unsubscribed = "unsubscribed"--stringToMessageType "chat" = Chat-stringToMessageType "error" = MessageError-stringToMessageType "groupchat" = Groupchat-stringToMessageType "headline" = Headline-stringToMessageType "normal" = Normal-stringToMessageType s = OtherMessageType s--messageTypeToString Chat = "chat"-messageTypeToString MessageError = "error"-messageTypeToString Groupchat = "groupchat"-messageTypeToString Headline = "headline"-messageTypeToString Normal = "normal"-messageTypeToString (OtherMessageType s) = s
Network/XMPP/Stanza.hs view
@@ -19,16 +19,17 @@ -} --- | 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--- --- This module will be documented soon.+-- |+-- 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+--+-- This module will be documented soon. -- Received stanzas can be assumed to have their ID and to fields set. @@ -57,22 +58,12 @@ import Network.XMPP.JID +import Network.XMPP.Types+ import Data.XML.Types import qualified Data.Text as DT import Data.Maybe (fromJust) -data StanzaID = SID String deriving (Eq, Show)-type From = JID-type To = JID-type XMLLang = String -- Validate, protect---data Stanza = Stanza { stanzaID :: Maybe StanzaID- , stanzaFrom :: Maybe From- , stanzaTo :: Maybe To- , stanzaLang :: Maybe XMLLang } deriving (Eq, Show)-- stanza :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang -> Stanza stanza i f t l = Stanza { stanzaID = i@@ -81,19 +72,6 @@ , stanzaLang = l } -data MessageType = Chat |- MessageError |- Groupchat |- Headline |- Normal | -- Default- OtherMessageType String deriving (Eq, Show)---data Message = Message { messageStanza :: Stanza- , messageType :: MessageType- , messagePayload :: [Element] } deriving (Eq, Show)-- message :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang -> MessageType -> [Element] -> Message @@ -102,31 +80,6 @@ , messagePayload = p } -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- PresenceError | -- ^ Processing or delivery of previously- -- sent presence stanza failed- Available | -- Not part of type='' [...]- -- Away |- -- Chat |- -- DoNotDisturb |- -- ExtendedAway |- Unavailable- deriving (Eq, Show)----- | Presence stanzas are used to express an entity's network availability.--data Presence = Presence { presenceStanza :: Stanza- , presenceType :: PresenceType- , presencePayload :: [Element] } deriving (Eq, Show)-- presence :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang -> PresenceType -> [Element] -> Presence @@ -138,12 +91,6 @@ , presencePayload = p } -data IQ = IQGet { iqGetStanza :: Stanza, iqGetPayload :: Element } |- IQSet { iqSetStanza :: Stanza, iqSetPayload :: Element } |- IQResult { iqResultStanza :: Stanza- , iqResultPayload :: Maybe Element } deriving (Eq, Show)-- iqGet :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang -> Element -> IQ @@ -196,64 +143,6 @@ -- Get the id from existing IQ getId :: IQ -> StanzaID getId iq = fromJust $ stanzaID $ iqStanza iq---- =============================================================================--- CODE NOT YET USED--- =============================================================================----- | All stanzas (IQ, message, presence) can cause errors, which looks like--- <stanza-kind to='sender' type='error'>. These errors are of one of the--- types listed below.--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)----- | The stanza errors are accommodated with one of the error conditions listed--- below. The ones that are not self-explainatory should be documented 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) -- IM/RFC:
+ Network/XMPP/Stream.hs view
@@ -0,0 +1,456 @@+-----------------------------------------------------------------------------+--+-- 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.JID+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+ s = presenceStanza p++ from :: String+ from = case stanzaFrom $ presenceStanza p of+ -- TODO: Lower-case+ Just s -> " from='" ++ (jidToString s) ++ "'"+ Nothing -> ""++ id' :: String+ id' = case stanzaID s of+ Just (SID s) -> " id='" ++ s ++ "'"+ Nothing -> ""++ to :: String+ to = case stanzaTo $ presenceStanza p of+ -- TODO: Lower-case+ Just s -> " to='" ++ (jidToString s) ++ "'"+ Nothing -> ""++ type' :: String+ type' = case presenceType p of+ Available -> ""+ t -> " type='" ++ (presenceTypeToString t) ++ "'"++iqToXML :: IQ -> String+iqToXML IQGet { iqGetStanza = s, iqGetPayload = p } =+ let type' = " type='get'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString (Just p)) ++ "</iq>"+ where+ from :: String+ from = case stanzaFrom s of+ -- TODO: Lower-case+ Just s -> " from='" ++ (jidToString s) ++ "'"+ Nothing -> ""++ id' :: String+ id' = case stanzaID s of+ Just (SID s) -> " id='" ++ s ++ "'"+ Nothing -> ""++ to :: String+ to = case stanzaTo s of+ -- TODO: Lower-case+ Just s -> " to='" ++ (jidToString s) ++ "'"+ Nothing -> ""++iqToXML IQSet { iqSetStanza = s, iqSetPayload = p } =+ let type' = " type='set'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString (Just p)) ++ "</iq>"+ where+ from :: String+ from = case stanzaFrom s of+ -- TODO: Lower-case+ Just s -> " from='" ++ (jidToString s) ++ "'"+ Nothing -> ""++ id' :: String+ id' = case stanzaID s of+ Just (SID s) -> " id='" ++ s ++ "'"+ Nothing -> ""++ to :: String+ to = case stanzaTo s of+ -- TODO: Lower-case+ Just s -> " to='" ++ (jidToString s) ++ "'"+ Nothing -> ""++iqToXML IQResult { iqResultStanza = s, iqResultPayload = p } =+ let type' = " type='result'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString p) ++ "</iq>"+ where+ from :: String+ from = case stanzaFrom s of+ -- TODO: Lower-case+ Just s -> " from='" ++ (jidToString s) ++ "'"+ Nothing -> ""++ id' :: String+ id' = case stanzaID s of+ Just (SID s) -> " id='" ++ s ++ "'"+ Nothing -> ""++ to :: String+ to = case stanzaTo s of+ -- TODO: Lower-case+ Just s -> " to='" ++ (jidToString s) ++ "'"+ Nothing -> ""++messageToXML :: Message -> String+messageToXML m = "<message" ++ from ++ id' ++ to ++ type' ++ ">" +++ (elementsToString $ messagePayload m) ++ "</message>"+ where+ s = messageStanza m++ from :: String+ from = case stanzaFrom $ messageStanza m of+ -- TODO: Lower-case+ Just s -> " from='" ++ (jidToString s) ++ "'"+ Nothing -> ""++ id' :: String+ id' = case stanzaID s of+ Just (SID s) -> " id='" ++ s ++ "'"+ Nothing -> ""++ to :: String+ to = case stanzaTo $ messageStanza m of+ -- TODO: Lower-case+ Just s -> " to='" ++ (jidToString s) ++ "'"+ Nothing -> ""++ type' :: String+ type' = case messageType m of+ Normal -> ""+ t -> " type='" ++ (messageTypeToString t) ++ "'"+++parseIQ :: Element -> IQ+parseIQ e | typeAttr == "get" = let (Just payloadMust) = payload+ in iqGet idAttr fromAttr toAttr Nothing+ payloadMust+ | typeAttr == "set" = let (Just payloadMust) = payload+ in iqSet idAttr fromAttr toAttr Nothing+ payloadMust+ | typeAttr == "result" = iqResult idAttr fromAttr toAttr Nothing+ payload++ where+ -- TODO: Many duplicate functions from parsePresence.++ payload :: Maybe Element+ payload = case null (elementChildren e) of+ True -> Nothing+ False -> Just $ head $ elementChildren e++ typeAttr :: String+ typeAttr = case attributeText typeName e of+ -- Nothing -> Nothing+ Just a -> DT.unpack a++ fromAttr :: Maybe JID+ fromAttr = case attributeText fromName e of+ Nothing -> Nothing+ Just a -> stringToJID $ DT.unpack a++ toAttr :: Maybe JID+ toAttr = case attributeText toName e of+ Nothing -> Nothing+ Just a -> stringToJID $ DT.unpack a++ idAttr :: Maybe StanzaID+ idAttr = case attributeText idName e of+ Nothing -> Nothing+ Just a -> Just (SID (DT.unpack a))++ typeName :: Name+ typeName = fromString "type"++ fromName :: Name+ fromName = fromString "from"++ toName :: Name+ toName = fromString "to"++ idName :: Name+ idName = fromString "id"++-- TODO: Parse xml:lang++parsePresence :: Element -> Presence+parsePresence e = presence idAttr fromAttr toAttr Nothing typeAttr (elementChildren e)+ where+ -- TODO: Many duplicate functions from parseIQ.++ typeAttr :: PresenceType+ typeAttr = case attributeText typeName e of+ Just t -> stringToPresenceType $ DT.unpack t+ Nothing -> Available++ fromAttr :: Maybe JID+ fromAttr = case attributeText fromName e of+ Nothing -> Nothing+ Just a -> stringToJID $ DT.unpack a++ toAttr :: Maybe JID+ toAttr = case attributeText toName e of+ Nothing -> Nothing+ Just a -> stringToJID $ DT.unpack a++ idAttr :: Maybe StanzaID+ idAttr = case attributeText idName e of+ Nothing -> Nothing+ Just a -> Just (SID (DT.unpack a))++ fromName :: Name+ fromName = fromString "from"++ typeName :: Name+ typeName = fromString "type"++ toName :: Name+ toName = fromString "to"++ idName :: Name+ idName = fromString "id"++parseMessage :: Element -> Message+parseMessage e = message idAttr fromAttr toAttr Nothing typeAttr (elementChildren e)+ where+ -- TODO: Many duplicate functions from parseIQ.++ typeAttr :: MessageType+ typeAttr = case attributeText typeName e of+ Just t -> stringToMessageType $ DT.unpack t+ Nothing -> Normal++ fromAttr :: Maybe JID+ fromAttr = case attributeText fromName e of+ Nothing -> Nothing+ Just a -> stringToJID $ DT.unpack a++ toAttr :: Maybe JID+ toAttr = case attributeText toName e of+ Nothing -> Nothing+ Just a -> stringToJID $ DT.unpack a++ idAttr :: Maybe StanzaID+ idAttr = case attributeText idName e of+ Nothing -> Nothing+ Just a -> Just (SID (DT.unpack a))++ fromName :: Name+ fromName = fromString "from"++ typeName :: Name+ typeName = fromString "type"++ toName :: Name+ toName = fromString "to"++ idName :: Name+ idName = fromString "id"++-- stringToPresenceType "available" = Available+-- stringToPresenceType "away" = Away+-- stringToPresenceType "chat" = Chat+-- stringToPresenceType "dnd" = DoNotDisturb+-- stringToPresenceType "xa" = ExtendedAway++stringToPresenceType "probe" = Probe+-- stringToPresenceType "error" = PresenceError -- 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 view
@@ -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 view
@@ -0,0 +1,337 @@+-----------------------------------------------------------------------------+--+-- 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 (+ HostName+ , Password+ , PortNumber+ , Resource+ , UserName,++EnumeratorEvent (..),+Challenge (..),+Success (..),+TLSState (..),+JID (..),+StanzaID (..),+From,+To,+XMLLang,+Stanza (..),+MessageType (..),+Message (..),+PresenceType (..),+Presence (..),+IQ (..),+InternalEvent (..),+XMLEvent (..),+ConnectionState (..),+ClientEvent (..),+StreamState (..),+AuthenticationState (..),+Certificate,+ConnectResult (..),+OpenStreamResult (..),+SecureWithTLSResult (..),+AuthenticateResult (..),+ServerAddress (..),+XMPPError (..),+StanzaError (..),+StanzaErrorType (..),+StanzaErrorCondition (..),+Timeout,+TimeoutEvent (..),+StreamError (..),+XMLString+) 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+++type XMLString = String++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 (JID) 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)+++data StanzaID = SID String deriving (Eq, Show)+type From = JID+type To = JID+type XMLLang = String -- Validate, protect+++data Stanza = Stanza { stanzaID :: Maybe StanzaID+ , stanzaFrom :: Maybe From+ , stanzaTo :: Maybe To+ , stanzaLang :: Maybe XMLLang } deriving (Eq, Show)+++data MessageType = Chat |+ Error_ |+ Groupchat |+ Headline |+ Normal | -- Default+ OtherMessageType String deriving (Eq, Show)+++data Message = Message { messageStanza :: Stanza+ , messageType :: MessageType+ , messagePayload :: [Element] } |+ MessageError { messageErrorStanza :: Stanza+ , messageErrorPayload :: Maybe [Element]+ , messageErrorStanzaError :: StanzaError } deriving (Eq, Show)++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+ -- PresenceError | -- ^ Processing or delivery of previously+ -- sent presence stanza failed+ Available | -- Not part of type='' [...]+ -- Away |+ -- Chat |+ -- DoNotDisturb |+ -- ExtendedAway |+ Unavailable+ deriving (Eq, Show)+++-- | Presence stanzas are used to express an entity's network availability.++data Presence = Presence { presenceStanza :: Stanza+ , presenceType :: PresenceType+ , presencePayload :: [Element] } |+ PresenceError { presenceErrorStanza :: Stanza+ , presenceErrorPayload :: Maybe [Element]+ , presenceErrorStanzaError :: StanzaError } deriving (Eq, Show)+++-- | All stanzas (IQ, message, presence) can cause errors, which looks like+-- <stanza-kind to='sender' type='error'>. These errors are of one of the+-- types listed below.++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)+++-- | The stanza errors are accommodated with one of the error conditions listed+-- below. The ones that are not self-explainatory should be documented 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)+++data IQ = IQGet { iqGetStanza :: Stanza, iqGetPayload :: Element } |+ IQSet { iqSetStanza :: Stanza, iqSetPayload :: Element } |+ IQResult { iqResultStanza :: Stanza+ , iqResultPayload :: Maybe Element } |+ IQError { iqErrorStanza :: Stanza, iqErrorPayload :: Maybe Element, iqErrorStanzaError :: StanzaError } deriving (Eq, Show)+++data StanzaError = StanzaError { stanzaErrorType :: StanzaErrorType+ , stanzaErrorCondition :: StanzaErrorCondition+ , stanzaErrorText :: Maybe String+ , stanzaErrorApplicationSpecificCondition ::+ Maybe Element } deriving (Eq, 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++-- JID is a data type that has to be constructed in this module using either jid+-- or stringToJID.++data JID = JID { jidNode :: Maybe String+ , jidServer :: String+ , jidResource :: Maybe String } deriving (Eq, Show)++data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq)++type Timeout = Int++data StreamError = StreamError
Network/XMPP/Utilities.hs view
@@ -19,17 +19,18 @@ -} --- | 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.+-- |+-- 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@@ -106,7 +107,7 @@ 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 } =@@ -115,13 +116,13 @@ 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) ++
README view
@@ -15,7 +15,7 @@ We are currently working on general improvements and having the library support all of RFC 3920: XMPP Core. -The next version, 0.1 Alpha 5, is scheduled to be released on the 15th of June.+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
pontarius-xmpp.cabal view
@@ -2,20 +2,20 @@ -- TODO: Highlighting bug: The last line of the description. Name: pontarius-xmpp-Version: 0.0.4.0+Version: 0.0.5.0 Cabal-Version: >= 1.6 Build-Type: Simple License: LGPL-3 License-File: LICENSE-Copyright: Copyright © 2011, Jon Kristensen+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: http://www.pontarius.org/releases/pontarius-xmpp-0.0.4.0.tar.gz+Package-URL: http://www.pontarius.org/releases/pontarius-xmpp-0.0.5.0.tar.gz Synopsis: A (prototyped) secure and easy to use XMPP library-Description: A work in progress of an implementation of RFC 3920: XMPP+Description: A work in progress of an implementation of RFC 6120: XMPP: Core. Category: Network Tested-With: GHC ==6.12.3@@ -27,12 +27,13 @@ Library Exposed-Modules: Network.XMPP, Network.XMPP.JID, 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, enumerator, crypto-api, base64-string, regex-posix, pureMD5, utf8-string, network, xml-types, text, transformers, bytestring, binary, random,- xml-enumerator, tls ==0.4.1, containers+ xml-enumerator, tls ==0.4.1, containers, mtl -- Other-Modules: -- HS-Source-Dirs: -- Extensions:@@ -90,5 +91,6 @@ Type: darcs -- Module: Location: https://patch-tag.com/r/jonkri/pontarius-xmpp- Tag: 0.0.4.0+ Tag: 0.0.5.0 -- Subdir:+