diff --git a/Documentation/Pontarius XMPP Manual.lyx b/Documentation/Pontarius XMPP Manual.lyx new file mode 100644 --- /dev/null +++ b/Documentation/Pontarius XMPP Manual.lyx @@ -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 diff --git a/Documentation/Software Design Description for Pontarius XMPP 1.0.lyx b/Documentation/Software Design Description for Pontarius XMPP 1.0.lyx new file mode 100644 --- /dev/null +++ b/Documentation/Software Design Description for Pontarius XMPP 1.0.lyx @@ -0,0 +1,192 @@ +#LyX 2.0 created this file. For more info see http://www.lyx.org/ +\lyxformat 413 +\begin_document +\begin_header +\textclass article +\use_default_options true +\maintain_unincluded_children false +\language english +\language_package default +\inputencoding auto +\fontencoding global +\font_roman default +\font_sans default +\font_typewriter default +\font_default_family default +\use_non_tex_fonts false +\font_sc false +\font_osf false +\font_sf_scale 100 +\font_tt_scale 100 + +\graphics default +\default_output_format default +\output_sync 0 +\bibtex_command default +\index_command default +\paperfontsize default +\use_hyperref false +\papersize default +\use_geometry false +\use_amsmath 1 +\use_esint 1 +\use_mhchem 1 +\use_mathdots 1 +\cite_engine basic +\use_bibtopic false +\use_indices false +\paperorientation portrait +\suppress_date false +\use_refstyle 1 +\index Index +\shortcut idx +\color #008000 +\end_index +\secnumdepth 3 +\tocdepth 3 +\paragraph_separation indent +\paragraph_indentation default +\quotes_language english +\papercolumns 1 +\papersides 1 +\paperpagestyle default +\tracking_changes false +\output_changes false +\html_math_output 0 +\html_css_as_file 0 +\html_be_strict false +\end_header + +\begin_body + +\begin_layout Title +Software Design Description for Pontarius XMPP 1.0 (First Draft) +\end_layout + +\begin_layout Author +The Pontarius Project +\end_layout + +\begin_layout Date +15th of June, 2011 +\end_layout + +\begin_layout Standard +\begin_inset CommandInset toc +LatexCommand tableofcontents + +\end_inset + + +\end_layout + +\begin_layout Section +Introduction +\end_layout + +\begin_layout Standard +Purpose +\end_layout + +\begin_layout Standard +Scope +\end_layout + +\begin_layout Standard +Definitions and acronyms +\end_layout + +\begin_layout Section +References +\end_layout + +\begin_layout Section +Decomposition description +\end_layout + +\begin_layout Subsection +Module decomposition +\end_layout + +\begin_layout Subsection +Concurrent process decomposition +\end_layout + +\begin_layout Subsection +Data decomposition +\end_layout + +\begin_layout Section +Dependency description +\end_layout + +\begin_layout Subsection +Intermodule dependencies +\end_layout + +\begin_layout Subsection +Interprocess dependencies +\end_layout + +\begin_layout Subsection +Data dependencies +\end_layout + +\begin_layout Section +Interface description +\end_layout + +\begin_layout Subsection +Module interface +\end_layout + +\begin_layout Subsubsection +Module 1 description +\end_layout + +\begin_layout Subsubsection +Module 2 description +\end_layout + +\begin_layout Subsection +Process interface +\end_layout + +\begin_layout Subsubsection +Process 1 description +\end_layout + +\begin_layout Subsubsection +Process 2 description +\end_layout + +\begin_layout Section +Detailed design +\end_layout + +\begin_layout Subsection +Module detailed design +\end_layout + +\begin_layout Subsubsection +Module 1 detail +\end_layout + +\begin_layout Subsubsection +Module 2 detail +\end_layout + +\begin_layout Subsection +Data detailed design +\end_layout + +\begin_layout Subsubsection +Module 1 detail +\end_layout + +\begin_layout Subsubsection +Module 2 detail +\end_layout + +\end_body +\end_document diff --git a/Documentation/Software Quality Assurance Plan for Pontarius XMPP 1.0.lyx b/Documentation/Software Quality Assurance Plan for Pontarius XMPP 1.0.lyx new file mode 100644 --- /dev/null +++ b/Documentation/Software Quality Assurance Plan for Pontarius XMPP 1.0.lyx @@ -0,0 +1,324 @@ +#LyX 2.0 created this file. For more info see http://www.lyx.org/ +\lyxformat 413 +\begin_document +\begin_header +\textclass article +\use_default_options true +\maintain_unincluded_children false +\language english +\language_package default +\inputencoding auto +\fontencoding global +\font_roman default +\font_sans default +\font_typewriter default +\font_default_family default +\use_non_tex_fonts false +\font_sc false +\font_osf false +\font_sf_scale 100 +\font_tt_scale 100 + +\graphics default +\default_output_format default +\output_sync 0 +\bibtex_command default +\index_command default +\paperfontsize default +\use_hyperref false +\papersize default +\use_geometry false +\use_amsmath 1 +\use_esint 1 +\use_mhchem 1 +\use_mathdots 1 +\cite_engine basic +\use_bibtopic false +\use_indices false +\paperorientation portrait +\suppress_date false +\use_refstyle 1 +\index Index +\shortcut idx +\color #008000 +\end_index +\secnumdepth 3 +\tocdepth 3 +\paragraph_separation indent +\paragraph_indentation default +\quotes_language english +\papercolumns 1 +\papersides 1 +\paperpagestyle default +\tracking_changes false +\output_changes false +\html_math_output 0 +\html_css_as_file 0 +\html_be_strict false +\end_header + +\begin_body + +\begin_layout Title +Software Quality Assurance Plan for Pontarius XMPP 1.0 +\end_layout + +\begin_layout Author +Jon Kristensen +\end_layout + +\begin_layout Date +6th of June, 2011 +\end_layout + +\begin_layout Standard +\begin_inset CommandInset toc +LatexCommand tableofcontents + +\end_inset + + +\end_layout + +\begin_layout Section +Purpose +\end_layout + +\begin_layout Standard +The purpose of writing this SQAP is not only to increase the quality of + Pontarius XMPP, but also to evaluate the use of the IEEE Standard for Software + Quality Assurance Plans (IEEE Std 730-1998) standard as well as meeting + the goals of a university course in IT quality management. + For information on the intended use of the software, please consult the + Pontarius XMPP 1.0 Software Requirement Specification. + The applicable portions of the software's life cycle from its first beta + until its disposal phase. +\end_layout + +\begin_layout Section +Reference documents +\end_layout + +\begin_layout Enumerate +IEEE Standard for Software Quality Assurance Plans (IEEE Std 730-1998) +\end_layout + +\begin_layout Enumerate +Pontarius XMPP 1.0 Software Requirement Specification +\end_layout + +\begin_layout Section +Legal notice +\end_layout + +\begin_layout Standard +Pontarius XMPP is a free and open source software project. + The +\begin_inset Quotes eld +\end_inset + +Pontarius project +\begin_inset Quotes erd +\end_inset + + is not a legal entity, but is like a synonym for Jon Kristensen. + Jon Kristensen does DOES NOT TAKE ANY RESPONSIBILITY OR OFFER ANY GUARANTEES + in regards to the software, its quality or this document. + Furthermore, the software is provided +\begin_inset Quotes eld +\end_inset + +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE +\begin_inset Quotes erd +\end_inset + +. + Consult the GNU General Public License for more information. + This aspect particularly influences the next section of this document. +\end_layout + +\begin_layout Section +Management +\end_layout + +\begin_layout Standard +The +\begin_inset Quotes eld +\end_inset + +organization +\begin_inset Quotes erd +\end_inset + + behind the software is the project founder, project leader, and copyright + holder Jon Kristensen, which acts in a +\begin_inset Quotes eld +\end_inset + +benevolent dictator +\begin_inset Quotes erd +\end_inset + + position for the free and open source project. + The Pontarius project hopes that Pontarius XMPP will grow to become the + de-facto XMPP library for Haskell, and that we will get voluntary feedback + from multiple testers from different communities, such as the Haskell and + XMPP communities, as well as the free and open source software community + as a whole. + We will do what we can to organize and act on that feedback; however, the + only person that has currently even +\emph on +planned +\emph default + to perform software quality assurance activities is Jon Kristensen. +\end_layout + +\begin_layout Standard +[Lifecycle of software, Sequence of tasks (with emphasis on activities), + relationships between tasks and major checkpoints] +\end_layout + +\begin_layout Standard +(Testing API, extending Pontarius XMPP with a set of RFCs and/or XEPs, unit + testing, performance testing, stress testing, code (un)coverage...) +\end_layout + +\begin_layout Section +Documentation +\end_layout + +\begin_layout Subsection +Purpose +\end_layout + +\begin_layout Subsection +Minimum documentation requirements +\end_layout + +\begin_layout Subsubsection +Software Requirements Specification +\end_layout + +\begin_layout Subsubsection +Software Design Description +\end_layout + +\begin_layout Subsubsection +Software Verification and Validation Plan +\end_layout + +\begin_layout Subsubsection +User Documentation +\end_layout + +\begin_layout Subsubsection +Software Configuration Management Plan +\end_layout + +\begin_layout Section +Standards, practices, conventions, and metrics +\end_layout + +\begin_layout Subsection +Purpose +\end_layout + +\begin_layout Subsection +Content +\end_layout + +\begin_layout Section +Reviews and audits +\end_layout + +\begin_layout Subsection +Purpose +\end_layout + +\begin_layout Subsection +Minimum requirements +\end_layout + +\begin_layout Subsection +Software Requirements Review +\end_layout + +\begin_layout Subsection +Preliminary Design Review +\end_layout + +\begin_layout Subsection +Critical Design Review +\end_layout + +\begin_layout Subsection +Software Verification and Validation Plan Review +\end_layout + +\begin_layout Subsubsection +Functional audit +\end_layout + +\begin_layout Subsubsection +Physical audit +\end_layout + +\begin_layout Subsubsection +In-process audits +\end_layout + +\begin_layout Subsubsection +Manegerial reviews +\end_layout + +\begin_layout Subsubsection +Software Configuration Management Plan Review +\end_layout + +\begin_layout Subsubsection +Post-mortem review +\end_layout + +\begin_layout Subsubsection +User Documentation Review +\end_layout + +\begin_layout Subsection +Test +\end_layout + +\begin_layout Section +Problem reporting and corrective actions +\end_layout + +\begin_layout Section +Tools, technologies, and methodologies +\end_layout + +\begin_layout Section +Code control +\end_layout + +\begin_layout Section +Media control +\end_layout + +\begin_layout Section +Supplier control +\end_layout + +\begin_layout Section +Records collection, maintainance, and retention +\end_layout + +\begin_layout Section +Training +\end_layout + +\begin_layout Section +Risk management +\end_layout + +\end_body +\end_document diff --git a/Documentation/Software Requirements Specification for Pontarius XMPP.lyx b/Documentation/Software Requirements Specification for Pontarius XMPP.lyx new file mode 100644 --- /dev/null +++ b/Documentation/Software Requirements Specification for Pontarius XMPP.lyx @@ -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 + + + + + + + +\begin_inset Text + +\begin_layout Plain Layout +Name (Mnemonic) +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +Version Number +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +Purpose +\end_layout + +\end_inset + + + + +\begin_inset Text + +\begin_layout Plain Layout +base +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + + + +\begin_inset Text + +\begin_layout Plain Layout +base64-string +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + + + +\begin_inset Text + +\begin_layout Plain Layout +binary +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + + + +\begin_inset Text + +\begin_layout Plain Layout +bytestring +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + + + +\begin_inset Text + +\begin_layout Plain Layout +containers +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + + + +\begin_inset Text + +\begin_layout Plain Layout +crypto-api +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + + + +\begin_inset Text + +\begin_layout Plain Layout +enumerator +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + + + +\begin_inset Text + +\begin_layout Plain Layout +hslogger +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + + + +\begin_inset Text + +\begin_layout Plain Layout +network +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + + + +\begin_inset Text + +\begin_layout Plain Layout +pureMD5 +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + + + +\begin_inset Text + +\begin_layout Plain Layout +QuickCheck +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + + + +\begin_inset Text + +\begin_layout Plain Layout +random +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + + + +\begin_inset Text + +\begin_layout Plain Layout +regex-posix +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + + + +\begin_inset Text + +\begin_layout Plain Layout +text +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + + + +\begin_inset Text + +\begin_layout Plain Layout +tls +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +0.4.1 +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + + + +\begin_inset Text + +\begin_layout Plain Layout +transformers +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + + + +\begin_inset Text + +\begin_layout Plain Layout +utf8-string +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + + + +\begin_inset Text + +\begin_layout Plain Layout +xml-enumerator +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + + + +\begin_inset Text + +\begin_layout Plain Layout +xml-types +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + +\begin_inset Text + +\begin_layout Plain Layout +N/A +\end_layout + +\end_inset + + + + +\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 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 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 , 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 diff --git a/Examples/EchoClient.hs b/Examples/EchoClient.hs --- a/Examples/EchoClient.hs +++ b/Examples/EchoClient.hs @@ -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 diff --git a/Network/XMPP.hs b/Network/XMPP.hs --- a/Network/XMPP.hs +++ b/Network/XMPP.hs @@ -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 -- 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 + diff --git a/Network/XMPP/Extensions/XEP0030.hs b/Network/XMPP/Extensions/XEP0030.hs new file mode 100644 --- /dev/null +++ b/Network/XMPP/Extensions/XEP0030.hs @@ -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 diff --git a/Network/XMPP/Extensions/XEP0115.hs b/Network/XMPP/Extensions/XEP0115.hs new file mode 100644 --- /dev/null +++ b/Network/XMPP/Extensions/XEP0115.hs @@ -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 + + + diff --git a/Network/XMPP/JID.hs b/Network/XMPP/JID.hs --- a/Network/XMPP/JID.hs +++ b/Network/XMPP/JID.hs @@ -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 diff --git a/Network/XMPP/Session.hs b/Network/XMPP/Session.hs --- a/Network/XMPP/Session.hs +++ b/Network/XMPP/Session.hs @@ -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 "" (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 "" 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 ("" ++ "") 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: ? @@ -674,74 +535,109 @@ lift $ liftIO $ send ("") handleOrTLSCtx put $ state { stateAuthenticationState = AuthenticatedUnbound userName resource } return Nothing - + IEE EnumeratorDone -> -- TODO: Exit? return Nothing - + -- --------------------------------------------------------------------------- -- XML EVENTS -- --------------------------------------------------------------------------- - + -- Ignore id="bind_1" and session IQ result, otherwise create client event - IEE (EnumeratorXML (XEIQ iqEvent)) -> do + 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 = "" ++ - (elementsToString $ presencePayload p) ++ "" - where - s = presenceStanza p - - from :: String - from = case stanzaFrom $ presenceStanza p of - -- TODO: Lower-case - Just s -> " from='" ++ (jidToString s) ++ "'" - Nothing -> "" - - id' :: String - id' = case stanzaID s of - Just (SID s) -> " id='" ++ s ++ "'" - Nothing -> "" - - to :: String - to = case stanzaTo $ presenceStanza p of - -- TODO: Lower-case - Just s -> " to='" ++ (jidToString s) ++ "'" - Nothing -> "" - - type' :: String - type' = case presenceType p of - Available -> "" - t -> " type='" ++ (presenceTypeToString t) ++ "'" - -iqToXML :: IQ -> String -iqToXML IQGet { iqGetStanza = s, iqGetPayload = p } = - let type' = " type='get'" in "" ++ (elementToString (Just p)) ++ "" - where - from :: String - from = case stanzaFrom s of - -- TODO: Lower-case - Just s -> " from='" ++ (jidToString s) ++ "'" - Nothing -> "" - - id' :: String - id' = case stanzaID s of - Just (SID s) -> " id='" ++ s ++ "'" - Nothing -> "" - - to :: String - to = case stanzaTo s of - -- TODO: Lower-case - Just s -> " to='" ++ (jidToString s) ++ "'" - Nothing -> "" - -iqToXML IQSet { iqSetStanza = s, iqSetPayload = p } = - let type' = " type='set'" in "" ++ (elementToString (Just p)) ++ "" - where - from :: String - from = case stanzaFrom s of - -- TODO: Lower-case - Just s -> " from='" ++ (jidToString s) ++ "'" - Nothing -> "" - - id' :: String - id' = case stanzaID s of - Just (SID s) -> " id='" ++ s ++ "'" - Nothing -> "" - - to :: String - to = case stanzaTo s of - -- TODO: Lower-case - Just s -> " to='" ++ (jidToString s) ++ "'" - Nothing -> "" - -iqToXML IQResult { iqResultStanza = s, iqResultPayload = p } = - let type' = " type='result'" in "" ++ (elementToString p) ++ "" - where - from :: String - from = case stanzaFrom s of - -- TODO: Lower-case - Just s -> " from='" ++ (jidToString s) ++ "'" - Nothing -> "" - - id' :: String - id' = case stanzaID s of - Just (SID s) -> " id='" ++ s ++ "'" - Nothing -> "" - - to :: String - to = case stanzaTo s of - -- TODO: Lower-case - Just s -> " to='" ++ (jidToString s) ++ "'" - Nothing -> "" - -messageToXML :: Message -> String -messageToXML m = "" ++ - (elementsToString $ messagePayload m) ++ "" - where - s = messageStanza m - - from :: String - from = case stanzaFrom $ messageStanza m of - -- TODO: Lower-case - Just s -> " from='" ++ (jidToString s) ++ "'" - Nothing -> "" - - id' :: String - id' = case stanzaID s of - Just (SID s) -> " id='" ++ s ++ "'" - Nothing -> "" - - to :: String - to = case stanzaTo $ messageStanza m of - -- TODO: Lower-case - Just s -> " to='" ++ (jidToString s) ++ "'" - Nothing -> "" - - type' :: String - type' = case messageType m of - Normal -> "" - t -> " type='" ++ (messageTypeToString t) ++ "'" - - -parseIQ :: Element -> IQ -parseIQ e | typeAttr == "get" = let (Just payloadMust) = payload - in iqGet idAttr fromAttr toAttr Nothing - payloadMust - | typeAttr == "set" = let (Just payloadMust) = payload - in iqSet idAttr fromAttr toAttr Nothing - payloadMust - | typeAttr == "result" = iqResult idAttr fromAttr toAttr Nothing - payload - - where - -- TODO: Many duplicate functions from parsePresence. - - payload :: Maybe Element - payload = case null (elementChildren e) of - True -> Nothing - False -> Just $ head $ elementChildren e - - typeAttr :: String - typeAttr = case attributeText typeName e of - -- Nothing -> Nothing - Just a -> DT.unpack a - - fromAttr :: Maybe JID - fromAttr = case attributeText fromName e of - Nothing -> Nothing - Just a -> stringToJID $ DT.unpack a - - toAttr :: Maybe JID - toAttr = case attributeText toName e of - Nothing -> Nothing - Just a -> stringToJID $ DT.unpack a - - idAttr :: Maybe StanzaID - idAttr = case attributeText idName e of - Nothing -> Nothing - Just a -> Just (SID (DT.unpack a)) - - typeName :: Name - typeName = fromString "type" - - fromName :: Name - fromName = fromString "from" - - toName :: Name - toName = fromString "to" - - idName :: Name - idName = fromString "id" - --- TODO: Parse xml:lang - -parsePresence :: Element -> Presence -parsePresence e = presence idAttr fromAttr toAttr Nothing typeAttr (elementChildren e) - where - -- TODO: Many duplicate functions from parseIQ. - - typeAttr :: PresenceType - typeAttr = case attributeText typeName e of - Just t -> stringToPresenceType $ DT.unpack t - Nothing -> Available - - fromAttr :: Maybe JID - fromAttr = case attributeText fromName e of - Nothing -> Nothing - Just a -> stringToJID $ DT.unpack a - - toAttr :: Maybe JID - toAttr = case attributeText toName e of - Nothing -> Nothing - Just a -> stringToJID $ DT.unpack a - - idAttr :: Maybe StanzaID - idAttr = case attributeText idName e of - Nothing -> Nothing - Just a -> Just (SID (DT.unpack a)) - - fromName :: Name - fromName = fromString "from" - - typeName :: Name - typeName = fromString "type" - - toName :: Name - toName = fromString "to" - - idName :: Name - idName = fromString "id" - -parseMessage :: Element -> Message -parseMessage e = message idAttr fromAttr toAttr Nothing typeAttr (elementChildren e) - where - -- TODO: Many duplicate functions from parseIQ. - - typeAttr :: MessageType - typeAttr = case attributeText typeName e of - Just t -> stringToMessageType $ DT.unpack t - Nothing -> Normal - - fromAttr :: Maybe JID - fromAttr = case attributeText fromName e of - Nothing -> Nothing - Just a -> stringToJID $ DT.unpack a - - toAttr :: Maybe JID - toAttr = case attributeText toName e of - Nothing -> Nothing - Just a -> stringToJID $ DT.unpack a - - idAttr :: Maybe StanzaID - idAttr = case attributeText idName e of - Nothing -> Nothing - Just a -> Just (SID (DT.unpack a)) - - fromName :: Name - fromName = fromString "from" - - typeName :: Name - typeName = fromString "type" - - toName :: Name - toName = fromString "to" - - idName :: Name - idName = fromString "id" - --- stringToPresenceType "available" = Available --- stringToPresenceType "away" = Away --- stringToPresenceType "chat" = Chat --- stringToPresenceType "dnd" = DoNotDisturb --- stringToPresenceType "xa" = ExtendedAway - -stringToPresenceType "probe" = Probe -stringToPresenceType "error" = PresenceError - -stringToPresenceType "unavailable" = Unavailable -stringToPresenceType "subscribe" = Subscribe -stringToPresenceType "subscribed" = Subscribed -stringToPresenceType "unsubscribe" = Unsubscribe -stringToPresenceType "unsubscribed" = Unsubscribed - --- presenceTypeToString Available = "available" - --- presenceTypeToString Away = "away" --- presenceTypeToString Chat = "chat" --- presenceTypeToString DoNotDisturb = "dnd" --- presenceTypeToString ExtendedAway = "xa" - -presenceTypeToString Unavailable = "unavailable" - -presenceTypeToString Probe = "probe" -presenceTypeToString PresenceError = "error" - -presenceTypeToString Subscribe = "subscribe" -presenceTypeToString Subscribed = "subscribed" -presenceTypeToString Unsubscribe = "unsubscribe" -presenceTypeToString Unsubscribed = "unsubscribed" - -stringToMessageType "chat" = Chat -stringToMessageType "error" = MessageError -stringToMessageType "groupchat" = Groupchat -stringToMessageType "headline" = Headline -stringToMessageType "normal" = Normal -stringToMessageType s = OtherMessageType s - -messageTypeToString Chat = "chat" -messageTypeToString MessageError = "error" -messageTypeToString Groupchat = "groupchat" -messageTypeToString Headline = "headline" -messageTypeToString Normal = "normal" -messageTypeToString (OtherMessageType s) = s diff --git a/Network/XMPP/Stanza.hs b/Network/XMPP/Stanza.hs --- a/Network/XMPP/Stanza.hs +++ b/Network/XMPP/Stanza.hs @@ -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 --- . 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: diff --git a/Network/XMPP/Stream.hs b/Network/XMPP/Stream.hs new file mode 100644 --- /dev/null +++ b/Network/XMPP/Stream.hs @@ -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 = "" ++ + (elementsToString $ presencePayload p) ++ "" + where + s = presenceStanza p + + from :: String + from = case stanzaFrom $ presenceStanza p of + -- TODO: Lower-case + Just s -> " from='" ++ (jidToString s) ++ "'" + Nothing -> "" + + id' :: String + id' = case stanzaID s of + Just (SID s) -> " id='" ++ s ++ "'" + Nothing -> "" + + to :: String + to = case stanzaTo $ presenceStanza p of + -- TODO: Lower-case + Just s -> " to='" ++ (jidToString s) ++ "'" + Nothing -> "" + + type' :: String + type' = case presenceType p of + Available -> "" + t -> " type='" ++ (presenceTypeToString t) ++ "'" + +iqToXML :: IQ -> String +iqToXML IQGet { iqGetStanza = s, iqGetPayload = p } = + let type' = " type='get'" in "" ++ (elementToString (Just p)) ++ "" + where + from :: String + from = case stanzaFrom s of + -- TODO: Lower-case + Just s -> " from='" ++ (jidToString s) ++ "'" + Nothing -> "" + + id' :: String + id' = case stanzaID s of + Just (SID s) -> " id='" ++ s ++ "'" + Nothing -> "" + + to :: String + to = case stanzaTo s of + -- TODO: Lower-case + Just s -> " to='" ++ (jidToString s) ++ "'" + Nothing -> "" + +iqToXML IQSet { iqSetStanza = s, iqSetPayload = p } = + let type' = " type='set'" in "" ++ (elementToString (Just p)) ++ "" + where + from :: String + from = case stanzaFrom s of + -- TODO: Lower-case + Just s -> " from='" ++ (jidToString s) ++ "'" + Nothing -> "" + + id' :: String + id' = case stanzaID s of + Just (SID s) -> " id='" ++ s ++ "'" + Nothing -> "" + + to :: String + to = case stanzaTo s of + -- TODO: Lower-case + Just s -> " to='" ++ (jidToString s) ++ "'" + Nothing -> "" + +iqToXML IQResult { iqResultStanza = s, iqResultPayload = p } = + let type' = " type='result'" in "" ++ (elementToString p) ++ "" + where + from :: String + from = case stanzaFrom s of + -- TODO: Lower-case + Just s -> " from='" ++ (jidToString s) ++ "'" + Nothing -> "" + + id' :: String + id' = case stanzaID s of + Just (SID s) -> " id='" ++ s ++ "'" + Nothing -> "" + + to :: String + to = case stanzaTo s of + -- TODO: Lower-case + Just s -> " to='" ++ (jidToString s) ++ "'" + Nothing -> "" + +messageToXML :: Message -> String +messageToXML m = "" ++ + (elementsToString $ messagePayload m) ++ "" + where + s = messageStanza m + + from :: String + from = case stanzaFrom $ messageStanza m of + -- TODO: Lower-case + Just s -> " from='" ++ (jidToString s) ++ "'" + Nothing -> "" + + id' :: String + id' = case stanzaID s of + Just (SID s) -> " id='" ++ s ++ "'" + Nothing -> "" + + to :: String + to = case stanzaTo $ messageStanza m of + -- TODO: Lower-case + Just s -> " to='" ++ (jidToString s) ++ "'" + Nothing -> "" + + type' :: String + type' = case messageType m of + Normal -> "" + t -> " type='" ++ (messageTypeToString t) ++ "'" + + +parseIQ :: Element -> IQ +parseIQ e | typeAttr == "get" = let (Just payloadMust) = payload + in iqGet idAttr fromAttr toAttr Nothing + payloadMust + | typeAttr == "set" = let (Just payloadMust) = payload + in iqSet idAttr fromAttr toAttr Nothing + payloadMust + | typeAttr == "result" = iqResult idAttr fromAttr toAttr Nothing + payload + + where + -- TODO: Many duplicate functions from parsePresence. + + payload :: Maybe Element + payload = case null (elementChildren e) of + True -> Nothing + False -> Just $ head $ elementChildren e + + typeAttr :: String + typeAttr = case attributeText typeName e of + -- Nothing -> Nothing + Just a -> DT.unpack a + + fromAttr :: Maybe JID + fromAttr = case attributeText fromName e of + Nothing -> Nothing + Just a -> stringToJID $ DT.unpack a + + toAttr :: Maybe JID + toAttr = case attributeText toName e of + Nothing -> Nothing + Just a -> stringToJID $ DT.unpack a + + idAttr :: Maybe StanzaID + idAttr = case attributeText idName e of + Nothing -> Nothing + Just a -> Just (SID (DT.unpack a)) + + typeName :: Name + typeName = fromString "type" + + fromName :: Name + fromName = fromString "from" + + toName :: Name + toName = fromString "to" + + idName :: Name + idName = fromString "id" + +-- TODO: Parse xml:lang + +parsePresence :: Element -> Presence +parsePresence e = presence idAttr fromAttr toAttr Nothing typeAttr (elementChildren e) + where + -- TODO: Many duplicate functions from parseIQ. + + typeAttr :: PresenceType + typeAttr = case attributeText typeName e of + Just t -> stringToPresenceType $ DT.unpack t + Nothing -> Available + + fromAttr :: Maybe JID + fromAttr = case attributeText fromName e of + Nothing -> Nothing + Just a -> stringToJID $ DT.unpack a + + toAttr :: Maybe JID + toAttr = case attributeText toName e of + Nothing -> Nothing + Just a -> stringToJID $ DT.unpack a + + idAttr :: Maybe StanzaID + idAttr = case attributeText idName e of + Nothing -> Nothing + Just a -> Just (SID (DT.unpack a)) + + fromName :: Name + fromName = fromString "from" + + typeName :: Name + typeName = fromString "type" + + toName :: Name + toName = fromString "to" + + idName :: Name + idName = fromString "id" + +parseMessage :: Element -> Message +parseMessage e = message idAttr fromAttr toAttr Nothing typeAttr (elementChildren e) + where + -- TODO: Many duplicate functions from parseIQ. + + typeAttr :: MessageType + typeAttr = case attributeText typeName e of + Just t -> stringToMessageType $ DT.unpack t + Nothing -> Normal + + fromAttr :: Maybe JID + fromAttr = case attributeText fromName e of + Nothing -> Nothing + Just a -> stringToJID $ DT.unpack a + + toAttr :: Maybe JID + toAttr = case attributeText toName e of + Nothing -> Nothing + Just a -> stringToJID $ DT.unpack a + + idAttr :: Maybe StanzaID + idAttr = case attributeText idName e of + Nothing -> Nothing + Just a -> Just (SID (DT.unpack a)) + + fromName :: Name + fromName = fromString "from" + + typeName :: Name + typeName = fromString "type" + + toName :: Name + toName = fromString "to" + + idName :: Name + idName = fromString "id" + +-- stringToPresenceType "available" = Available +-- stringToPresenceType "away" = Away +-- stringToPresenceType "chat" = Chat +-- stringToPresenceType "dnd" = DoNotDisturb +-- stringToPresenceType "xa" = ExtendedAway + +stringToPresenceType "probe" = Probe +-- stringToPresenceType "error" = PresenceError -- 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 diff --git a/Network/XMPP/TLS.hs b/Network/XMPP/TLS.hs new file mode 100644 --- /dev/null +++ b/Network/XMPP/TLS.hs @@ -0,0 +1,47 @@ +----------------------------------------------------------------------------- +-- +-- Module : Network.XMPP.TLS +-- Copyright : Copyright © 2011, Jon Kristensen +-- License : LGPL (Just (Version {versionBranch = [3], versionTags = []})) +-- +-- Maintainer : jon.kristensen@pontarius.org +-- Stability : alpha +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module Network.XMPP.TLS ( +getTLSParams, +handshake' +) where + +import Network.TLS +import Network.TLS.Cipher +import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput) + + +getTLSParams :: TLSParams +getTLSParams = TLSParams { pConnectVersion = TLS10 + , pAllowedVersions = [TLS10,TLS11] + , pCiphers = [cipher_AES256_SHA1] -- Check the rest + , pCompressions = [nullCompression] + , pWantClientCert = False + , pCertificates = [] + , onCertificatesRecv = \_ -> return True } -- Verify cert chain + +handshake' :: Handle -> String -> IO (Maybe TLSCtx) +handshake' h s = do + let t = getTLSParams + r <- makeSRandomGen + case r of + Right sr -> do + putStrLn $ show sr + c <- client t sr h + handshake c + putStrLn ">>>>TLS data sended<<<<" + return (Just c) + Left ge -> do + putStrLn $ show ge + return Nothing diff --git a/Network/XMPP/Types.hs b/Network/XMPP/Types.hs new file mode 100644 --- /dev/null +++ b/Network/XMPP/Types.hs @@ -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 +-- . 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 diff --git a/Network/XMPP/Utilities.hs b/Network/XMPP/Utilities.hs --- a/Network/XMPP/Utilities.hs +++ b/Network/XMPP/Utilities.hs @@ -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) ++ diff --git a/README b/README --- a/README +++ b/README @@ -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 and the Pontarius XMPP Hackage page for more diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -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: +