diff --git a/Documentation/Pontarius XMPP Manual.lyx b/Documentation/Pontarius XMPP Manual.lyx deleted file mode 100644 --- a/Documentation/Pontarius XMPP Manual.lyx +++ /dev/null @@ -1,591 +0,0 @@ -#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 (Fourth Draft) -\end_layout - -\begin_layout Author -The Pontarius Project -\end_layout - -\begin_layout Date -The 27th of July, 2011 -\end_layout - -\begin_layout Standard -\begin_inset CommandInset toc -LatexCommand tableofcontents - -\end_inset - - -\end_layout - -\begin_layout Section -Introduction -\end_layout - -\begin_layout Standard -Pontarius XMPP 0.1 is a minimal XMPP client implementation with all the required - client features and behaviours of the RFC 6120 ("XMPP Core") specification -\begin_inset Foot -status open - -\begin_layout Plain Layout -http://tools.ietf.org/html/rfc6120 -\end_layout - -\end_inset - -. - Pontarius XMPP has been developed by the Pontarius project (mainly by Jon - Kristensen). - -\series bold - -\series default -Being licensed under a three-clause BSD 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 XMPP Core specification (RFC 6120). - Features include the following: -\end_layout - -\begin_layout Itemize -Connecting and disconnecting from an XMPP server -\end_layout - -\begin_layout Itemize -Opening the XMPP streams -\end_layout - -\begin_layout Itemize -Securing XMPP streams with TLS -\end_layout - -\begin_layout Itemize -Authenticate using SASL -\end_layout - -\begin_layout Itemize -Perform resource binding -\end_layout - -\begin_layout Itemize -Send and receive stanzas (message, presence, and IQ) and stanza errors -\end_layout - -\begin_layout Itemize -Send and receive stream errors -\end_layout - -\begin_layout Standard -Below are the specifics of our implementation: -\end_layout - -\begin_layout Itemize -Pontarius XMPP is a client library; the application using Pontarius XMPP - is always the -\begin_inset Quotes eld -\end_inset - -initiating entity -\begin_inset Quotes erd -\end_inset - - -\end_layout - -\begin_layout Itemize -A client-to-server connection always consists of exactly one TCP connection -\end_layout - -\begin_layout Itemize -For stream security through TLS, only the TLS_RSA_WITH_AES_128_CBC_SHA cipher - suite is supported -\end_layout - -\begin_layout Itemize -TLS renegotiation is not supported -\end_layout - -\begin_layout Itemize -TLS channel binding is not supported -\end_layout - -\begin_layout Itemize -For (SASL) authentication, the SHA-1 variant of SASL Salted Challenge Response - Authentication Mechanism (SCRAM-SHA-1) is the only supported mechanism -\end_layout - -\begin_layout Section -Future Development -\end_layout - -\begin_layout Standard -The current goal for Pontarius XMPP 0.2 is to implement the Extended Personal - Media Network (XPMN) architecture so that the Pontarius project can develop - a media server and some other XPMN services on top of Pontarius XMPP. - However, if we get approached by people wanting to use Pontarius XMPP for - other things, we might decide to help them out by implement some other - features first. - Please let us know if you are looking for a Haskell XMPP library and Pontarius - XMPP lacks some features that you want. -\end_layout - -\begin_layout Section -Usage -\end_layout - -\begin_layout Standard -Working with Pontarius XMPP is mostly done asynchronously; Pontarius XMPP - ``owns'' the XMPP thread, and calls different StateT s m a callback functions - in the client. - StateT is a monad transformer which allows the functions to be stateful - (being able to access and modify the arbitrary client-defined state of - type s) and to be executed on top of a MonadIO m monad (typically IO). -\end_layout - -\begin_layout Subsection -Creating the session -\end_layout - -\begin_layout Standard -Setting up an XMPP session is done through the (blocking) session function: -\end_layout - -\begin_layout Standard -\begin_inset listings -inline false -status open - -\begin_layout Plain Layout - -session :: (MonadIO m, ClientState s m) => s -> -\end_layout - -\begin_layout Plain Layout - - [ClientHandler s m] -> (StateT s m ()) -> m () -\end_layout - -\end_inset - - -\end_layout - -\begin_layout Standard -The first parameter (of type s) is an arbitrary state that is defined by - the client. - This is the initial state, and it will be passed to the stateful client - callbacks. - It will typically be modified by the client. -\end_layout - -\begin_layout Standard -The second parameter is the list of client handlers to deal with XMPP callbacks. - The reason why we have a list is because we want to provide a ``layered'' - system of XMPP event handlers. - For example, XMPP client developers may want to have a dedicated handler - to manage messages, implement a spam protection system, and so on. - Messages are piped through these handlers one by one, and any handler may - block the message from being sent to the next handler(s) above in the stack. -\end_layout - -\begin_layout Standard -\begin_inset listings -inline false -status open - -\begin_layout Plain Layout - -data MonadIO m => ClientHandler s m = ClientHandler { -\end_layout - -\begin_layout Plain Layout - - messageReceived :: Maybe (Message -> -\end_layout - -\begin_layout Plain Layout - - StateT s m Bool), presenceReceived :: Maybe -\end_layout - -\begin_layout Plain Layout - - (Presence -> StateT s m Bool), iqReceived :: -\end_layout - -\begin_layout Plain Layout - - Maybe (IQ -> StateT s m Bool), -\end_layout - -\begin_layout Plain Layout - - sessionTerminated :: Maybe (TerminationReason -> -\end_layout - -\begin_layout Plain Layout - - StateT s m ()) } -\end_layout - -\end_inset - - -\end_layout - -\begin_layout Standard -ClientHandler is a record which specifies four callback functions. - The first three deals with the three XMPP stanzas, and are called once - an XMPP stanza is received. - These functions take the stanza in question, and are stateful with the - current client state. - The boolean value returned signals whether or not the message should be - blocked to clients further down the stack. - For example, a XEP-0030: Service Discovery handler may choose to hide disco#inf -o requests handlers above it in the stack. - The last function is the callback that is used when the XMPP session is - terminated. - All callbacks are optional. -\end_layout - -\begin_layout Standard -The third argument to session is a callback function that will be called - when the session has been initialized. -\end_layout - -\begin_layout Standard -Any function with access to the Session object can operate with the XMPP - session, such as connecting the XMPP client or sending stanzas. - More on this below. -\end_layout - -\begin_layout Subsection -Connecting the client -\end_layout - -\begin_layout Standard -Different clients connect to XMPP in different ways. - Some secure the stream with TLS, and some authenticate with the server. - Pontarius XMPP provides a flexible function to help out with this in a - convenient way: -\end_layout - -\begin_layout Standard -\begin_inset listings -inline false -status open - -\begin_layout Plain Layout - -connect :: MonadIO m => Session s m -> HostName -> -\end_layout - -\begin_layout Plain Layout - - PortNumber -> Maybe (Certificate, (Certificate -> -\end_layout - -\begin_layout Plain Layout - - Bool)) -> Maybe (UserName, Password, Maybe -\end_layout - -\begin_layout Plain Layout - - Resource) -> (ConnectResult -> StateT s m ()) -> -\end_layout - -\begin_layout Plain Layout - - StateT s m () -\end_layout - -\end_inset - - -\end_layout - -\begin_layout Standard -This function simply takes the host name and port number to connect to, - an optional tuple of the certificate to use and a function evaluating certifica -tes for TLS (if Nothing is provided, the connection will not be TLS secured), - and another optional tuple with user name, password, and an optional resource - for authentication (analogously, providing Nothing here causes Pontarius - XMPP not to authenticate). - The final paramter is a callback function providing the result of the connect - action. -\end_layout - -\begin_layout Standard -For more fine-grained control of the connection, use the openStream, secureWithT -LS, and authenticate functions. -\end_layout - -\begin_layout Subsection -Managing XMPP addresses -\end_layout - -\begin_layout Standard -As with email, XMPP uses globally unique addresses (or JIDs, as they are - also called) in order to route and deliver messages over the network. - All XMPP entities are addressable on the local network. -\end_layout - -\begin_layout Standard -There are four functions dealing with XMPP addresses: -\end_layout - -\begin_layout Standard -\begin_inset listings -inline false -status open - -\begin_layout Plain Layout - -fromString :: String -> Maybe Address -\end_layout - -\begin_layout Plain Layout - -fromStrings :: Maybe String -> String -> -\end_layout - -\begin_layout Plain Layout - - Maybe String -> Maybe Address -\end_layout - -\begin_layout Plain Layout - -isBare :: Address -> Bool -\end_layout - -\begin_layout Plain Layout - -isFull :: Address -> Bool -\end_layout - -\end_inset - - -\end_layout - -\begin_layout Standard -These functions should be pretty self-explainatory to those who know the - XMPP: Core standard. - The fromString functions takes one to three strings and tries to construct - an XMPP address. - isBare and isFull checks whether or not the bare is full (has a resource - value). -\end_layout - -\begin_layout Subsection -Sending stanzas -\end_layout - -\begin_layout Standard -Sending messages is done using this function: -\end_layout - -\begin_layout Standard -\begin_inset listings -inline false -status open - -\begin_layout Plain Layout - -sendMessage :: MonadIO m => Session s m -> Message -> -\end_layout - -\begin_layout Plain Layout - - Maybe (Message -> StateT s m Bool) -> -\end_layout - -\begin_layout Plain Layout - - Maybe (Timeout, StateT s m ()) -> -\end_layout - -\begin_layout Plain Layout - - Maybe (StreamError -> StateT s m ()) -> -\end_layout - -\begin_layout Plain Layout - - StateT s m () -\end_layout - -\end_inset - - -\end_layout - -\begin_layout Standard -Like in section 3.2, the first parameter is the session object. - The second is the message (check the Message record type in the API). - The third parameter is an optional callback function to be executed if - a reply to the message is received. - The fourth parameter contains a Timeout (Integer) value, and a callback - that Pontarius XMPP will call when a reply has not been received in the - window of the timeout. - The last parameter is an optional callback that is called if a stream error - occurs. -\end_layout - -\begin_layout Standard -Presence and IQ stanzas are sent in a very similar way. -\end_layout - -\begin_layout Standard -Stanza IDs will be set for you if you leave them out. - If, however, you want to know what ID you send, you can acquire a stanza - ID by calling the getID function: -\end_layout - -\begin_layout Standard -\begin_inset listings -inline false -status open - -\begin_layout Plain Layout - -getID :: MonadIO m => Session s m -> StateT s m String -\end_layout - -\end_inset - - -\end_layout - -\begin_layout Subsection -Concurrent usage -\end_layout - -\begin_layout Standard -Sometimes clients will want to perform XMPP actions from more than one thread, - or in other words, they want to perform actions from code that is not a - Pontarius XMPP callback. - For these use cases, use injectAction: -\end_layout - -\begin_layout Standard -\begin_inset listings -inline false -status open - -\begin_layout Plain Layout - -injectAction :: MonadIO m => Session s m -> -\end_layout - -\begin_layout Plain Layout - - Maybe (StateT s m Bool) -> StateT s m () -> -\end_layout - -\begin_layout Plain Layout - - StateT s m () -\end_layout - -\end_inset - - -\end_layout - -\begin_layout Standard -The second parameter is an optional predicate callback to be executed right - before the third parameter callback is called. - If it is provided and evaluates to False, then the action will not be called. - Otherwise, the action will be called. -\end_layout - -\begin_layout Subsection -Example echo server -\end_layout - -\begin_layout Standard -We provide an example to further illustrate the Pontarius XMPP API and to - make it easier for developers to get started with the library. - The program illustrates how to connect, authenticate, set a presence, and - echo all messages received. - It only uses one client handler. - The contents of this example may be used freely, as if it is in the public - domain. - You find it in the Examples directory of the Pontarius XMPP source code. -\end_layout - -\end_body -\end_document diff --git a/Documentation/Pontarius XMPP Manual.pdf b/Documentation/Pontarius XMPP Manual.pdf deleted file mode 100644 Binary files a/Documentation/Pontarius XMPP Manual.pdf and /dev/null differ diff --git a/Documentation/Software Requirements Specification for Pontarius XMPP.lyx b/Documentation/Software Requirements Specification for Pontarius XMPP.lyx deleted file mode 100644 --- a/Documentation/Software Requirements Specification for Pontarius XMPP.lyx +++ /dev/null @@ -1,1311 +0,0 @@ -#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 (Third Draft) -\end_layout - -\begin_layout Author -The Pontarius Project -\end_layout - -\begin_layout Date -27th of July 2011 -\end_layout - -\begin_layout Standard -\begin_inset CommandInset toc -LatexCommand tableofcontents - -\end_inset - - -\end_layout - -\begin_layout Section -Introduction -\end_layout - -\begin_layout 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, RFC 5246: The Transport Layer Security (TLS) Protocol Version 1.2, - RFC 4422: Simple Authentication and Security Layer (SASL), RFC 5280: Internet - X.509 Public Key Infrastructure Certificate and Certificate Revocation List - (CRL) Profile, and Extensible Markup Language (XML) 1.0, among others. -\end_layout - -\begin_layout Standard -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. - Server components and XMPP server capabilities could also be added later. -\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 the de facto---XMPP library for Haskell. - It should be correct and efficient to work in. -\end_layout - -\begin_layout Standard -We will not repeat the specifics of the requirements from the RFC 6120: - XMPP Core specification and its depending specifications in this document - unless we see any special reason to. -\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 WITHOUT ANY WARRANTY; without even - the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -\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 -PX01 Pontarius XMPP 0.1 -\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 (see also its depending specifications) -\end_layout - -\begin_layout Subsection -Overview -\end_layout - -\begin_layout Standard -The second section provides an overall description of the requirements of - PX01, 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 -PX01 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 -PX01 is designed to be used with Haskell. -\end_layout - -\begin_layout Standard -PX01 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 -PX01 must work with (at least) the (estimated) most popular free and open - source software XMPP server that works with the specifics of our implementation - (such as SCRAM). -\end_layout - -\begin_layout Standard -PX01 depends on the below (free and open source software) Haskell packages. - I have omitted specification number [...]. - I have also omitted the 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 PX01 client will open up at most one TCP port on the system. - PX01 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 -We will utilize -\emph on -at least -\emph default - Transport Layer Security to help protect clients using the library from - attacks. - PX01 will not provide any spam protection. -\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 PX01. - 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 -PX01 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 PX01 to understand the XMPP: Core specification - (and its depending specifications), 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 (active or inactive) - for a very long period of time, without problems of memory leaks, unnecessary - CPU usage, or similar, arising. -\end_layout - -\begin_layout Subsubsection -Assumptions and dependencies -\end_layout - -\begin_layout Standard -We assume that the Glasgow Haskell Compiler (GHC) is available on the system - where PX01 applications are built. -\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 (at least) the (estimated) most popular - free and open source software XMPP server supporting the features that - we require (such as SCRAM). -\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. -\end_layout - -\begin_layout Description -REQ-11 The API shall allow for perform resource binding on an authenticated - stream, either by trying to set a specific resource, or have the server - generate one. -\end_layout - -\begin_layout Standard -Rationale: Even though most clients wants to do REQ-8, 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-12 The API shall provide a convenience function for opening a stream, - securing the stream with TLS, authenticating an XMPP account, and perform - resource binding 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-13 The API shall provide the possibility for clients to close the stream. -\end_layout - -\begin_layout Description -REQ-14 The API shall provide the possibility for clients to send stream - errors. -\end_layout - -\begin_layout Description -REQ-15 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-16 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-17 The API shall allow for convenient construction of JabberIDs. -\end_layout - -\begin_layout Description -REQ-18 The API shall provide utility functions to check whether or not a - JID is full or bare. -\end_layout - -\begin_layout Description -REQ-19 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-20 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 Description -REQ-21 The library should generate an internal infinite list of unique stanza - IDs; the API should provide a way for application developers to acquire - any amount of such IDs -\end_layout - -\begin_layout Description -REQ-22 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-23 The system must a convenient API to deal with stanza and stream errors. -\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-24 Regular desktop computers should be able to run hundreds of Pontarius - XMPP 0.1 clients. -\end_layout - -\begin_layout Description -REQ-25 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-26 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-27 The system shall support one persistant TCP stream/connection between - the XMPP client and the XMPP server. -\end_layout - -\begin_layout Description -REQ-28 The system shall implement (at least) the TLS_RSA_WITH_AES_128_CBC_SHA - cipher suite for TLS. -\end_layout - -\begin_layout Description -REQ-29 The system shall support (at least) the SHA-1 variant of SASL Salted - Challenge Response Authentication Mechanism (SCRAM-SHA-1). -\end_layout - -\begin_layout Description -REQ-30 XML namespaces for stanzas should always be known to the client. -\end_layout - -\begin_layout Description -REQ-31 We must validate incoming XML (though not against the XML schemas). -\end_layout - -\begin_layout Description -REQ-32 The system shall always check for the appropriate features before - trying to use them. -\end_layout - -\begin_layout Description -REQ-33 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 Subsubsection -RFC 6122: XMPP: Address Format -\end_layout - -\begin_layout Description -REQ-34 JIDs should be validated, transformed, and internationalized in accordanc -e with the stringprep profiles Nodeprep, Nameprep, and Resourceprep. -\end_layout - -\begin_layout Description -REQ-35 JIDs should be able to use hostnames, IPv4 addresses, and IPv6 addresses, - as domainparts. -\end_layout - -\begin_layout Subsubsection -Standards compliance -\end_layout - -\begin_layout Description -REQ-36 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-37 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-38 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-39 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/Documentation/Software Requirements Specification for Pontarius XMPP.pdf b/Documentation/Software Requirements Specification for Pontarius XMPP.pdf deleted file mode 100644 Binary files a/Documentation/Software Requirements Specification for Pontarius XMPP.pdf and /dev/null differ diff --git a/Examples/EchoClient.hs b/Examples/EchoClient.hs deleted file mode 100644 --- a/Examples/EchoClient.hs +++ /dev/null @@ -1,147 +0,0 @@ -{- - -Copyright © 2010-2011 Jon Kristensen. - -This file (EchoClient.hs) illustrates how to connect, authenticate, set a -presence, and echo messages with Pontarius XMPP. The contents of this file may -be used freely, as if it is in the public domain. - -In any state-aware function (function operating in the StateT monad) you can get -and set the current by writing - -@CMS.get >>= \ state -> CMS.put $ state { stateTest = 10 } ...@ - -or, if you prefer the do-notation, - -@do - state <- CMS.get - CMS.put $ state { stateTest = 10 } - ...@ - --} - - -{-# LANGUAGE MultiParamTypeClasses #-} - - -module Examples.EchoClient () where - -import Network.XMPP - -import qualified Control.Monad as CM -import qualified Control.Monad.State as CMS -import qualified Control.Monad.IO.Class as CMIC -import qualified Data.Maybe as DM - - --- Account and server details. - -hostName = "jonkristensen.com" -userName = "pontarius" -serverIdentifier = "jonkristensen.com" -portNumber = 5222 -resource = "pontarius" -password = "substrat44" - - --- The client state, containing the required Pontarius XMPP Session object. It --- also contains a dummy integer value to illustrate how client states are used. - -data State = State { stateSession :: Maybe (Session State IO) - , stateTest :: Integer } - -defaultState :: State - -defaultState = State { stateSession = Nothing - , stateTest = 5 } - - -instance ClientState State IO where - putSession st se = st { stateSession = Just se } - - --- This client defines one client handler, and only specifies the --- messageReceived callback. - -clientHandlers = [ClientHandler { messageReceived = Just messageReceived_ - , presenceReceived = Nothing - , iqReceived = Nothing - , sessionTerminated = Nothing }] - - --- The main function sets up the Pontarius XMPP session with the default client --- state and client handler defined above, as well as specifying that the --- sessionCreated function should be called when the session has been created. - -main :: IO () - -main = do - session - defaultState - clientHandlers - sessionCreated - - --- The session has been created. Let's try to open the XMPP stream! - -sessionCreated :: CMS.StateT State IO () - -sessionCreated = do - state <- CMS.get - connect (DM.fromJust $ stateSession state) hostName portNumber - Nothing (Just (userName, password, Just resource)) - connectCallback - id <- getID (DM.fromJust $ stateSession state) - CMIC.liftIO $ putStrLn $ "Unique ID acquired: " ++ id - injectAction (DM.fromJust $ stateSession state) Nothing (do CMIC.liftIO $ putStrLn "Async action!"; return ()) - injectAction (DM.fromJust $ stateSession state) Nothing (do CMIC.liftIO $ putStrLn "Async action!"; return ()) - injectAction (DM.fromJust $ stateSession state) Nothing (do CMIC.liftIO $ putStrLn "Async action!"; return ()) - injectAction (DM.fromJust $ stateSession state) Nothing (do CMIC.liftIO $ putStrLn "Async action!"; return ()) - injectAction (DM.fromJust $ stateSession state) Nothing (do CMIC.liftIO $ putStrLn "Async action!"; return ()) - injectAction (DM.fromJust $ stateSession state) Nothing (do CMIC.liftIO $ putStrLn "Async action!"; return ()) - injectAction (DM.fromJust $ stateSession state) Nothing (do CMIC.liftIO $ putStrLn "Async action!"; return ()) - injectAction (DM.fromJust $ stateSession state) Nothing (do CMIC.liftIO $ putStrLn "Async action!"; return ()) - injectAction (DM.fromJust $ stateSession state) Nothing (do CMIC.liftIO $ putStrLn "Async action!"; return ()) - injectAction (DM.fromJust $ stateSession state) Nothing (do CMIC.liftIO $ putStrLn "Async action!"; return ()) - return () - - --- We have tried to connected, TLS secured and authenticated! - -connectCallback :: ConnectResult -> CMS.StateT State IO () - -connectCallback r = do - state <- CMS.get - case r of - ConnectSuccess _ _ _ -> do - sendPresence (DM.fromJust $ stateSession state) - Presence { presenceID = Nothing - , presenceFrom = Nothing - , presenceTo = Nothing - , presenceXMLLang = Nothing - , presenceType = Available - , presencePayload = [] } - Nothing Nothing Nothing - _ -> do - CMIC.liftIO $ putStrLn "Could not connect." - return () - - --- A message (stanza) has been received. Let's echo it! - -messageReceived_ :: Message -> CMS.StateT State IO Bool - -messageReceived_ m = do - state <- CMS.get - CMIC.liftIO $ putStrLn $ - "Received a message; echoing it! By the way: Internal state is " ++ - (show $ stateTest state) ++ "." - sendMessage (DM.fromJust $ stateSession state) - Message { messageID = messageID m - , messageFrom = Nothing - , messageTo = messageFrom m - , messageXMLLang = Nothing - , messageType = messageType m - , messagePayload = messagePayload m } - Nothing (Just (0, (do CMIC.liftIO $ putStrLn "Timeout!"; return ()))) Nothing - return True diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,15 @@ -Copyright © 2010-2011, Jon Kristensen. - -All rights reserved. - -Redistribution and use in source and binary forms, with or without modification, -are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. +Copyright © 2005-2011 Dmitry Astapov +Copyright © 2005-2011 Pierre Kovalev +Copyright © 2010-2011 Mahdi Abdinejadi +Copyright © 2010-2012 Jon Kristensen +Copyright © 2011 IETF Trust +Copyright © 2012 Philipp Balzarek - * The names of Jon Kristensen, the contributors of Pontarius XMPP, or the - contributors of the Pontarius project may not be used to endorse or promote - products derived from this software without specific prior written - permission. +Licensed under the Apache License, Version 2.0 (the "License"); you may not use +this file except in compliance with the License. You may obtain a copy of the +License at . -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL JON KRISTENSEN OR OTHER PONTARIUS XMPP OR -PONTARIUS DEVELOPERS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT -OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING -IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY -OF SUCH DAMAGE. +Unless required by applicable law or agreed to in writing, software distributed +under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR +CONDITIONS OF ANY KIND, either express or implied. See the License for the +specific language governing permissions and limitations under the License. diff --git a/Network/XMPP.hs b/Network/XMPP.hs deleted file mode 100644 --- a/Network/XMPP.hs +++ /dev/null @@ -1,83 +0,0 @@ --- Copyright © 2010-2011 Jon Kristensen. See the LICENSE file in the Pontarius --- XMPP distribution for more details. - --- | --- Module: $Header$ --- Description: Pontarius XMPP API --- Copyright: Copyright © 2010-2011 Jon Kristensen --- License: BSD3 --- --- Maintainer: info@pontarius.org --- Stability: unstable --- Portability: portable --- --- XMPP is an open standard, extendable, and secure communications protocol --- designed on top of XML, TLS, and SASL. Pontarius XMPP is an XMPP client --- library, implementing the core capabilities of XMPP (RFC 6120). --- --- Developers using this library are assumed to understand how XMPP works. --- --- This module will be documented soon. --- --- 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. - -module Network.XMPP ( -- Network.XMPP.JID - Address (..) - , Localpart - , Domainpart - , Resourcepart - , isFull - , isBare - , fromString - , fromStrings - - -- Network.XMPP.Session - , ClientHandler (..) - , ClientState (..) - , ConnectResult (..) - , HostName - , Password - , PortNumber - , Resource - , Session - , TerminationReason - , UserName - , sendIQ - , sendPresence - , sendMessage - , connect - , openStreams - , tlsSecureStreams - , authenticate - , session - , OpenStreamResult (..) - , SecureWithTLSResult (..) - , AuthenticateResult (..) - - -- Network.XMPP.Stanza - , StanzaID (SID) - , From - , To - , LangTag - , MessageType (..) - , Message (..) - , PresenceType (..) - , Presence (..) - , IQ (..) - , iqPayloadNamespace - , iqPayload - - , injectAction ) where - -import Network.XMPP.Address -import Network.XMPP.SASL -import Network.XMPP.Session -import Network.XMPP.Stanza -import Network.XMPP.Utilities -import Network.XMPP.Types -import Network.XMPP.TLS -import Network.XMPP.Stream - diff --git a/Network/XMPP/Address.hs b/Network/XMPP/Address.hs deleted file mode 100644 --- a/Network/XMPP/Address.hs +++ /dev/null @@ -1,189 +0,0 @@ --- Copyright © 2010-2011 Jon Kristensen. See the LICENSE file in the Pontarius --- XMPP distribution for more details. - -{-# OPTIONS_HADDOCK hide #-} - --- TODO: When no longer using stringprep, do appropriate testing. (Including --- testing addresses like a@b/c@d/e, a/b@c, a@/b, a/@b...) - --- TODO: Unicode 3.2 should be used. - - --- This module deals with XMPP addresses (also known as JIDs and JabberIDs). For --- more information on XMPP addresses, see RFC 6122: XMPP: Address Format. --- --- This module does not internationalize hostnames. - - -module Network.XMPP.Address (fromString, fromStrings, isBare, isFull) where - -import Network.XMPP.Types - -import Data.Maybe (fromJust, isJust) -import Text.Parsec ((<|>), anyToken, char, eof, many, noneOf, parse) -import Text.Parsec.ByteString (GenParser) - -import Text.StringPrep (StringPrepProfile (..), a1, b1, b2, c11, c12, c21, c22, - c3, c4, c5, c6, c7, c8, c9, runStringPrep) -import Text.NamePrep (namePrepProfile) - -import Network.URI (isIPv4address, isIPv6address) - -import qualified Data.ByteString.Char8 as DBC (pack) -import qualified Data.Text as DT (pack, unpack) - - --- | --- Converts a string to an XMPP address. - -fromString :: String -> Maybe Address - -fromString s = fromStrings localpart domainpart resourcepart - where - Right (localpart, domainpart, resourcepart) = - parse addressParts "" (DBC.pack s) - - --- | --- Converts localpart, domainpart, and resourcepart strings to an XMPP address. - --- Runs the appropriate stringprep profiles and validates the parts. - -fromStrings :: Maybe String -> String -> Maybe String -> Maybe Address - -fromStrings l s r - | domainpart == Nothing = Nothing - | otherwise = if validateNonDomainpart localpart && - isJust domainpart' && - validateNonDomainpart resourcepart - then Just (Address localpart (fromJust domainpart') resourcepart) - else Nothing - where - - -- Applies the nodeprep profile on the localpart string, if any. - localpart :: Maybe String - localpart = case l of - Just l' -> case runStringPrep nodeprepProfile (DT.pack l') of - Just l'' -> Just $ DT.unpack l'' - Nothing -> Nothing - Nothing -> Nothing - - -- Applies the nameprep profile on the domainpart string. - -- TODO: Allow unassigned? - domainpart :: Maybe String - domainpart = case runStringPrep (namePrepProfile False) (DT.pack s) of - Just s' -> Just $ DT.unpack s' - Nothing -> Nothing - - -- Applies the resourceprep profile on the resourcepart string, if any. - resourcepart :: Maybe String - resourcepart = case r of - Just r' -> case runStringPrep resourceprepProfile (DT.pack r') of - Just r'' -> Just $ DT.unpack r'' - Nothing -> Nothing - Nothing -> Nothing - - -- Returns the domainpart if it was a valid IP or if the toASCII - -- function was successful, or Nothing otherwise. - domainpart' :: Maybe String - domainpart' | isIPv4address s || isIPv6address s = Just s - | validHostname s = Just s - | otherwise = Nothing - - -- Validates that non-domainpart strings have an appropriate length. - validateNonDomainpart :: Maybe String -> Bool - validateNonDomainpart Nothing = True - validateNonDomainpart (Just l) = validPartLength l - where - validPartLength :: String -> Bool - validPartLength p = length p > 0 && length p < 1024 - - -- Validates a host name - validHostname :: String -> Bool - validHostname _ = True -- TODO - - --- | Returns True if the address is `bare', and False otherwise. - -isBare :: Address -> Bool - -isBare j | resourcepart j == Nothing = True - | otherwise = False - - --- | Returns True if the address is `full', and False otherwise. - -isFull :: Address -> Bool - -isFull jid = not $ isBare jid - - --- Parses an address string and returns its three parts. It performs no --- validation or transformations. We are using Parsec to parse the address. --- There is no input for which 'addressParts' fails. - -addressParts :: GenParser Char st (Maybe String, String, Maybe String) - -addressParts = do - - -- Read until we reach an '@', a '/', or EOF. - a <- many $ noneOf ['@', '/'] - - -- Case 1: We found an '@', and thus the localpart. At least the domainpart - -- is remaining. Read the '@' and until a '/' or EOF. - do - char '@' - b <- many $ noneOf ['/'] - - -- Case 1A: We found a '/' and thus have all the address parts. Read the - -- '/' and until EOF. - do - char '/' -- Resourcepart remaining - c <- many $ anyToken -- Parse resourcepart - eof - return (Just a, b, Just c) - - -- Case 1B: We have reached EOF; the address is in the form - -- localpart@domainpart. - <|> do - eof - return (Just a, b, Nothing) - - -- Case 2: We found a '/'; the address is in the form - -- domainpart/resourcepart. - <|> do - char '/' - b <- many $ anyToken - eof - return (Nothing, a, Just b) - - -- Case 3: We have reached EOF; we have an address consisting of only a - -- domainpart. - <|> do - eof - return (Nothing, a, Nothing) - - -nodeprepProfile :: StringPrepProfile - -nodeprepProfile = Profile { maps = [b1, b2] - , shouldNormalize = True - , prohibited = [a1] ++ [c11, c12, c21, c22, c3, c4, c5, c6, c7, c8, c9] - , shouldCheckBidi = True } - - --- These needs to be checked for after normalization. We could also look up the --- Unicode mappings and include a list of characters in the prohibited field --- above. Let's defer that until we know that we are going to use stringprep. - -nodeprepExtraProhibitedCharacters = ['\x22', '\x26', '\x27', '\x2F', '\x3A', - '\x3C', '\x3E', '\x40'] - - - -resourceprepProfile :: StringPrepProfile - -resourceprepProfile = Profile { maps = [b1] - , shouldNormalize = True - , prohibited = [a1] ++ [c12, c21, c22, c3, c4, c5, c6, c7, c8, c9] - , shouldCheckBidi = True } diff --git a/Network/XMPP/SASL.hs b/Network/XMPP/SASL.hs deleted file mode 100644 --- a/Network/XMPP/SASL.hs +++ /dev/null @@ -1,172 +0,0 @@ --- Copyright © 2010-2011 Jon Kristensen. See the LICENSE file in the Pontarius --- XMPP distribution for more details. - -{-# OPTIONS_HADDOCK hide #-} - --- TODO: Make it possible to include host. --- TODO: Host is assumed to be ISO 8859-1; make list of assumptions. --- TODO: Can it contain newline characters? - -module Network.XMPP.SASL (replyToChallenge, saltedPassword, clientKey, storedKey, authMessage, clientSignature, clientProof, serverKey, serverSignature) where - -import Prelude hiding (concat, zipWith) -import Data.ByteString.Internal (c2w) -import Data.Char (isLatin1) -import Data.Digest.Pure.MD5 -import qualified Data.ByteString.Lazy as DBL (ByteString, append, pack, - fromChunks, toChunks, null) -import qualified Data.ByteString.Lazy.Char8 as DBLC (append, pack, unpack) -import qualified Data.List as DL -import Data.Text (empty, singleton) -import Text.StringPrep (StringPrepProfile (..), a1, b1, c12, c21, c22, c3, c4, c5, c6, c7, c8, c9, runStringPrep) -import Data.Ranges (inRanges, ranges) - -import Crypto.HMAC (MacKey (MacKey), hmac) -import Crypto.Hash.SHA1 (SHA1, hash) -import Data.Bits (xor) -import Data.ByteString () -import Data.ByteString.Lazy (ByteString, concat, fromChunks, pack, toChunks, zipWith) -import Data.Serialize (Serialize, encodeLazy) -import Data.Serialize.Put (putWord32be, runPutLazy) - -import Data.Maybe (fromJust, isJust) - -import qualified Data.Text as DT - -import Text.StringPrep (runStringPrep) - -data Challenge1Error = C1MultipleCriticalAttributes | - C1NotAllParametersPresent | - C1SomeParamtersPresentMoreThanOnce | - C1WrongRealm | - C1UnsupportedAlgorithm | - C1UnsupportedCharset | - C1UnsupportedQOP - deriving Show - - --- Will produce a list of key-value pairs given a string in the format of --- realm="somerealm",nonce="OA6MG9tEQGm2hh",qop="auth",charset=utf-8... -stringToList :: String -> [(String, String)] -stringToList "" = [] -stringToList s' = let (next, rest) = break' s' ',' - in break' next '=' : stringToList rest - where - -- Like break, but will remove the first char of the continuation, if - -- present. - break' :: String -> Char -> (String, String) - break' s' c = let (first, second) = break ((==) c) s' - in (first, removeCharIfPresent second c) - - -- Removes the first character, if present; "=hello" with '=' becomes - -- "hello". - removeCharIfPresent :: String -> Char -> String - removeCharIfPresent [] _ = [] - removeCharIfPresent (c:t) c' | c == c' = t - removeCharIfPresent s' c = s' - --- Counts the number of directives in the pair list. -countDirectives :: String -> [(String, String)] -> Int -countDirectives v l = DL.length $ filter (isEntry v) l - where - isEntry :: String -> (String, String) -> Bool - isEntry name (name', _) | name == name' = True - | otherwise = False - - --- Returns the given directive in the list of pairs, or Nothing. -lookupDirective :: String -> [(String, String)] -> Maybe String -lookupDirective d [] = Nothing -lookupDirective d ((d', v):t) | d == d' = Just v - | otherwise = lookupDirective d t - - --- Returns the given directive in the list of pairs, or the default value --- otherwise. -lookupDirectiveWithDefault :: String -> [(String, String)] -> String -> String -lookupDirectiveWithDefault di l de - | lookup == Nothing = de - | otherwise = let Just r = lookup in r - where - lookup = lookupDirective di l - - --- Implementation of "Hi()" as specified in the Notation section of RFC 5802 --- ("SCRAM"). It takes a string "str", a salt, and an interation count, and --- returns an octet string. The iteration count must be greater than zero. - -hi :: ByteString -> ByteString -> Integer -> ByteString - -hi str salt i | i > 0 = xorUs $ us (concat [salt, runPutLazy $ putWord32be 1]) i - where - - -- Calculates the U's (U1 ... Ui) using the HMAC algorithm - us :: ByteString -> Integer -> [ByteString] - us a 1 = [encodeLazy (hmac (MacKey (head $ toChunks str)) a :: SHA1)] - us a x = [encodeLazy (hmac (MacKey (head $ toChunks str)) a :: SHA1)] ++ (us (encodeLazy (hmac (MacKey (head $ toChunks str)) a :: SHA1)) (x - 1)) - - -- XORs the ByteStrings: U1 XOR U2 XOR ... XOR Ui - xorUs :: [ByteString] -> ByteString - xorUs (b:bs) = foldl (\ x y -> pack $ zipWith xor x y) b bs - - -saltedPassword :: String -> ByteString -> Integer -> Maybe ByteString - -saltedPassword password salt i = if isJust password' then Just $ hi (DBLC.pack $ DT.unpack $ fromJust password') salt i else Nothing - where - password' = runStringPrep saslprepProfile (DT.pack password) - -clientKey :: ByteString -> ByteString - -clientKey sp = encodeLazy (hmac (MacKey (head $ toChunks sp)) (DBLC.pack "Client Key") :: SHA1) - - -storedKey :: ByteString -> ByteString - -storedKey ck = fromChunks [hash $ head $ toChunks ck] - - -authMessage :: String -> String -> String -> ByteString - -authMessage cfmb sfm cfmwp = DBLC.pack $ cfmb ++ "," ++ sfm ++ "," ++ cfmwp - - -clientSignature :: ByteString -> ByteString -> ByteString - -clientSignature sk am = encodeLazy (hmac (MacKey (head $ toChunks sk)) am :: SHA1) - - -clientProof :: ByteString -> ByteString -> ByteString - -clientProof ck cs = pack $ zipWith xor ck cs - - -serverKey :: ByteString -> ByteString - -serverKey sp = encodeLazy (hmac (MacKey (head $ toChunks sp)) (DBLC.pack "Server Key") :: SHA1) - - -serverSignature :: ByteString -> ByteString -> ByteString - -serverSignature servkey am = encodeLazy (hmac (MacKey (head $ toChunks servkey)) am :: SHA1) - - --- TODO: Implement SCRAM. - -replyToChallenge = replyToChallenge - - --- Stripts the quotations around a string, if any; "\"hello\"" becomes "hello". - -stripQuotations :: String -> String -stripQuotations "" = "" -stripQuotations s | (head s == '"') && (last s == '"') = tail $ init s - | otherwise = s - - -saslprepProfile :: StringPrepProfile - -saslprepProfile = Profile { maps = [\ char -> if char `inRanges` (ranges c12) then singleton '\x0020' else singleton char, b1] - , shouldNormalize = True - , prohibited = [a1] ++ [c12, c21, c22, c3, c4, c5, c6, c7, c8, c9] - , shouldCheckBidi = True } diff --git a/Network/XMPP/Session.hs b/Network/XMPP/Session.hs deleted file mode 100644 --- a/Network/XMPP/Session.hs +++ /dev/null @@ -1,762 +0,0 @@ --- Copyright © 2010-2011 Jon Kristensen. See the LICENSE file in the Pontarius --- XMPP distribution for more details. - --- 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 #-} - -{-# OPTIONS_HADDOCK hide #-} - --- 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. - --- 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? - -module Network.XMPP.Session ( ClientHandler (..) - , ClientState (..) - , ConnectResult (..) - , Session - , TerminationReason - , OpenStreamResult (..) - , SecureWithTLSResult (..) - , AuthenticateResult (..) - , sendPresence - , sendIQ - , sendMessage - , connect - , openStreams - , tlsSecureStreams - , authenticate - , session - , injectAction - , getID ) where - -import Network.XMPP.Address -import Network.XMPP.SASL -import Network.XMPP.Stanza -import Network.XMPP.Stream -import Network.XMPP.TLS -import Network.XMPP.Types -import Network.XMPP.Utilities - -import qualified Control.Exception as CE -import qualified Control.Exception.Base as CEB -- ? -import qualified Control.Monad.Error as CME -import qualified Control.Monad.State as CMS -import qualified Network as N - -------------- - -import Crypto.Random (newGenIO, SystemRandom) - -import Control.Concurrent.MVar - -import Codec.Binary.UTF8.String -import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) -import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay) -import Control.Monad.IO.Class (liftIO, MonadIO) -import Control.Monad.State hiding (State) -import Data.Enumerator (($$), Iteratee, continue, joinI, - run, run_, yield) -import Data.Enumerator.Binary (enumHandle, enumFile) -import Data.Maybe -import Data.String -import Data.XML.Types -import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput) -import Network.TLS -import Network.TLS.Cipher -import System.IO (BufferMode, BufferMode(NoBuffering)) -import Text.XML.Enumerator.Parse (parseBytes, decodeEntities) -import Text.XML.Enumerator.Document (fromEvents) -import qualified Codec.Binary.Base64.String as CBBS -import qualified Data.ByteString as DB -import qualified Data.ByteString.Lazy as DBL (ByteString, append, pack, fromChunks, toChunks, null) -import qualified Data.ByteString.Lazy.Char8 as DBLC (append, pack, unpack) -import qualified Data.Enumerator as E -import qualified Data.Enumerator.List as EL -import qualified Data.List as DL -import qualified Data.Text as DT -import qualified Data.Text.Lazy as DTL - -import Data.Certificate.X509 (X509) - -import Data.UUID (UUID, toString) - -import System.Random (randomIO) - - - --- ============================================================================= --- EXPORTED TYPES AND FUNCTIONS --- ============================================================================= - - --- | The @Session@ object is used by clients when interacting with Pontarius --- XMPP. It holds information needed by Pontarius XMPP; its content is not --- accessible from the client. - -data Session s m = Session { sessionChannel :: Chan (InternalEvent s m) - , sessionIDGenerator :: IDGenerator } - - --- | A client typically needs one or more @ClientHandler@ objects to interact --- with Pontarius XMPP. Each client handler may provide four callback --- functions; the first three callbacks deals with received stanzas, and the --- last one is used when the session is terminated. --- --- These stanza functions takes the current client state and an object --- containing the details of the stanza in question. The boolean returned --- along with the possibly updated state signals whether or not the message --- should be blocked to client handlerss further down the stack. For example, --- an XEP-0030: Service Discovery handler may choose to hide disco\#info --- requests to handlers above it in the stack. --- --- The 'sessionTerminated' callback function takes a 'TerminationReason' value --- along with the state and will be sent to all client handlers. - -data MonadIO m => ClientHandler s m = - ClientHandler { messageReceived :: Maybe (Message -> StateT s m Bool) - , presenceReceived :: Maybe (Presence -> StateT s m Bool) - , iqReceived :: Maybe (IQ -> StateT s m Bool) - , sessionTerminated :: Maybe (TerminationReason -> - StateT s m ()) } - - --- | @TerminationReason@ contains information on why the XMPP session was --- terminated. - -data TerminationReason = WhateverReason -- TODO - - --- | Creates an XMPP session. Blocks the current thread. The first parameter, --- @s@, is an arbitrary state that is defined by the client. This is the --- initial state, and it will be passed to the client (handlers) as XMPP --- events are emitted. The second parameter is the list of @ClientHandler@s; --- this is a way to provide a "layered" system of XMPP event handlers. For --- example, a client may have a dedicated handler to manage messages, --- implement a spam protection system, etc. Messages are piped through these --- handlers one by one, and any handler may block the message from being sent --- to the next handler(s) above in the stack. The third argument is a callback --- function that will be called when the session has been initialized, and --- this function should be used by the client to store the Session object in --- its state. - --- Creates the internal event channel, injects the Pontarius XMPP session object --- into the ClientState object, runs the "session created" client callback (in --- the new state context), and stores the updated client state in s''. Finally, --- we launch the (main) state loop of Pontarius XMPP. - -session :: (MonadIO m, ClientState s m) => s -> [ClientHandler s m] -> - (CMS.StateT s m ()) -> m () - -session s h c = do - threadID <- liftIO $ newEmptyMVar - chan <- liftIO $ newChan - idGenerator <- liftIO $ idGenerator "" -- TODO: Prefix - ((), clientState) <- runStateT c (putSession s $ session_ chan idGenerator) - (result, _) <- runStateT (stateLoop chan) - (defaultState chan threadID h clientState idGenerator) - case result of - Just (CE.SomeException e) -> do - liftIO $ putStrLn "Got an exception!" - threadID' <- liftIO $ tryTakeMVar threadID - case threadID' of - Nothing -> do - liftIO $ putStrLn "No thread ID to kill" - Just t -> do - liftIO $ putStrLn "Killing thread" - liftIO $ killThread t - CE.throw e - Nothing -> - return () - where - -- session :: Chan (InternalEvent m s) -> Session m s -- TODO - session_ c i = Session { sessionChannel = c, sessionIDGenerator = i } - - -defaultState :: (MonadIO m, ClientState s m) => Chan (InternalEvent s m) -> MVar ThreadId -> - [ClientHandler s m] -> s -> IDGenerator -> State s m - -defaultState c t h s i = State { stateClientHandlers = h - , stateClientState = s - , stateChannel = c - , stateConnectionState = Disconnected - , stateStreamState = PreStream - , stateTLSState = NoTLS - , stateOpenStreamsCallback = Nothing - , stateTLSSecureStreamsCallback = Nothing - , stateAuthenticateCallback = Nothing - , stateAuthenticationState = NoAuthentication - , stateResource = Nothing - , stateShouldExit = False - , stateThreadID = t - , statePresenceCallbacks = [] - , stateMessageCallbacks = [] - , stateIQCallbacks = [] - , stateTimeoutStanzaIDs = [] - , stateIDGenerator = i - , stateSASLRValue = Nothing } -- TODO: Prefix - - --- | --- Convenience function for calling "openStreams" and "tlsSecureStreams" and\/or --- "authenticate". See the documentation for the three separate functions for --- details on how they operate. - -connect :: MonadIO m => Session s m -> HostName -> PortNumber -> - Maybe (Maybe [X509], ([X509] -> Bool)) -> - Maybe (UserName, Password, Maybe Resource) -> - (ConnectResult -> StateT s m ()) -> StateT s m () - -connect s h p t a c = openStreams s h p connect' - where - connect' r = case r of - OpenStreamSuccess _ _ -> case t of -- TODO: Check for TLS support? - Just (certificate, certificateValidator) -> - tlsSecureStreams s certificate certificateValidator connect'' - Nothing -> connect'' (SecureWithTLSSuccess 1.0 "") -- TODO - OpenStreamFailure -> c ConnectOpenStreamFailure - connect'' r = case r of - SecureWithTLSSuccess _ _ -> case a of - Just (userName, password, resource) -> - authenticate s userName password resource connect''' - Nothing -> connect''' (AuthenticateSuccess 1.0 "" "todo") -- TODO - SecureWithTLSFailure -> c ConnectSecureWithTLSFailure - connect''' r = case r of - AuthenticateSuccess streamProperties streamFeatures resource -> - c (ConnectSuccess streamProperties streamFeatures (Just resource)) - AuthenticateFailure -> c ConnectAuthenticateFailure - - -openStreams :: MonadIO m => Session s m -> HostName -> PortNumber -> - (OpenStreamResult -> StateT s m ()) -> StateT s m () - -openStreams s h p c = CMS.get >>= - (\ state -> lift $ liftIO $ writeChan (sessionChannel s) - (IEC (CEOpenStream h p c))) - - --- | --- Tries to secure the connection with TLS. --- --- If the list of certificates is provided, they will be presented to the --- server. --- --- The third parameter is an optional custom validation function for the server --- certificates. Note that Pontarius XMPP will perform its own validation --- according to the RFC 6120, including comparing the domain name specified in --- the certificate against the connected server, as well as checking the --- integrity, and the certificate authorities. --- --- Note: The current implementation of `certificate' looks for trusted --- certificates in the /etc/ssl/certs directory. --- --- Note: The current implementation of `certificate' does not support parsing --- X509 extensions. Because of this, we will defer checking CRLs and/or OCSP --- services as well as checking for the basicConstraints cA boolean for the --- time-being. - -tlsSecureStreams :: MonadIO m => Session s m -> Maybe [X509] -> - ([X509] -> Bool) -> (SecureWithTLSResult -> StateT s m ()) -> StateT s m () - -tlsSecureStreams s c a c_ = CMS.get >>= - (\ state -> lift $ liftIO $ - writeChan (sessionChannel s) - (IEC (CESecureWithTLS c a c_))) - - --- | - -authenticate :: MonadIO m => Session s m -> UserName -> Password -> - Maybe Resource -> (AuthenticateResult -> StateT s m ()) -> - StateT s m () - -authenticate s u p r c = CMS.get >>= - (\ state -> lift $ liftIO $ - writeChan (sessionChannel s) - (IEC (CEAuthenticate u p r c))) - - -sendMessage :: MonadIO m => Session s m -> Message -> Maybe (Message -> StateT s m Bool) -> Maybe (Timeout, StateT s m ()) -> Maybe (StreamError -> StateT s m ()) -> StateT s m () -sendMessage se m c t st = CMS.get >>= - (\ state -> lift $ liftIO $ - writeChan (sessionChannel se) - (IEC (CEMessage m c t st))) - -sendPresence :: MonadIO m => Session s m -> Presence -> Maybe (Presence -> StateT s m Bool) -> Maybe (Timeout, StateT s m ()) -> Maybe (StreamError -> StateT s m ()) -> StateT s m () -sendPresence se p c t st = CMS.get >>= - (\ state -> lift $ liftIO $ - writeChan (sessionChannel se) - (IEC (CEPresence p c t st))) - -sendIQ :: MonadIO m => Session s m -> IQ -> Maybe (IQ -> StateT s m Bool) -> Maybe (Timeout, StateT s m ()) -> Maybe (StreamError -> StateT s m ()) -> StateT s m () -sendIQ se i c t st = CMS.get >>= - (\ state -> lift $ liftIO $ - writeChan (sessionChannel se) - (IEC (CEIQ i c t st))) - -injectAction :: MonadIO m => Session s m -> Maybe (StateT s m Bool) -> StateT s m () -> StateT s m () -injectAction s p a = CMS.get >>= - (\ state -> lift $ liftIO $ - writeChan (sessionChannel s) - (IEC (CEAction p a))) - -getID :: MonadIO m => Session s m -> StateT s m String -getID s = CMS.get >>= \ state -> lift $ liftIO $ nextID (sessionIDGenerator s) >>= \ id -> return id - --- xmppDisconnect :: MonadIO m => Session s m -> Maybe (s -> (Bool, s)) -> m () --- xmppDisconnect s c = xmppDisconnect s c - -class ClientState s m where - putSession :: s -> Session s m -> s - - --- ============================================================================= --- INTERNAL TYPES AND FUNCTIONS --- ============================================================================= - - -type OpenStreamCallback s m = Maybe (OpenStreamResult -> CMS.StateT s m ()) - -type SecureWithTLSCallback s m = Maybe (SecureWithTLSResult -> CMS.StateT s m ()) - -type AuthenticateCallback s m = Maybe (AuthenticateResult -> CMS.StateT s m ()) - - -isConnected :: ConnectionState -> Bool -isConnected Disconnected = True -isConnected (Connected _ _) = True - -data MonadIO m => State s m = - State { stateClientHandlers :: [ClientHandler s m] - , stateClientState :: s - , stateChannel :: Chan (InternalEvent s m) - , stateConnectionState :: ConnectionState -- s m - , stateTLSState :: TLSState - , stateStreamState :: StreamState - , stateOpenStreamsCallback :: OpenStreamCallback s m - , stateTLSSecureStreamsCallback :: SecureWithTLSCallback s m - , stateAuthenticateCallback :: AuthenticateCallback s m - , stateAuthenticationState :: AuthenticationState - , stateResource :: Maybe Resource - , stateShouldExit :: Bool - , stateThreadID :: MVar ThreadId - , statePresenceCallbacks :: [(StanzaID, (Presence -> StateT s m Bool))] - , stateMessageCallbacks :: [(StanzaID, (Message -> StateT s m Bool))] - , stateIQCallbacks :: [(StanzaID, (IQ -> StateT s m Bool))] - , stateTimeoutStanzaIDs :: [StanzaID] - , stateIDGenerator :: IDGenerator - , stateSASLRValue :: Maybe String - } - - --- Repeatedly reads internal events from the channel and processes them. This is --- the main loop of the XMPP session process. - --- The main loop of the XMPP library runs in the following monads: --- --- m, m => MonadIO (from the client) --- StateT --- ErrorT - --- TODO: Will >> carry the updated state? --- TODO: Should InternalState be in both places? - -stateLoop :: (MonadIO m, ClientState s m) => Chan (InternalEvent s m) -> - StateT (State s m) m (Maybe CE.SomeException) - -stateLoop c = do - event <- lift $ liftIO $ readChan c - lift $ liftIO $ putStrLn $ "Processing event " ++ (show event) ++ "." - result <- (processEvent event) - state <- get - case result of - Nothing -> do - case stateShouldExit state of - True -> - return $ Nothing - False -> - stateLoop c - Just e -> - return $ Just e - - --- Process an InternalEvent and performs the necessary IO and updates the state --- accordingly. - -processEvent :: (MonadIO m, ClientState s m) => (InternalEvent s m) -> - (StateT (State s m) m) (Maybe CE.SomeException) - -processEvent e = get >>= \ state -> - let handleOrTLSCtx = case stateTLSState state of - PostHandshake tlsCtx -> - Right tlsCtx - _ -> - let Connected _ handle = stateConnectionState state in Left handle - in case e of - - -- --------------------------------------------------------------------------- - -- CLIENT EVENTS - -- --------------------------------------------------------------------------- - -- - IEC (CEOpenStream hostName portNumber callback) -> do - - CEB.assert (stateConnectionState state == Disconnected) (return ()) - - let portNumber' = fromIntegral portNumber - - connectResult <- liftIO $ CE.try $ N.connectTo hostName - (N.PortNumber portNumber') - - case connectResult of - Right handle -> do - put $ state { stateConnectionState = Connected (ServerAddress hostName portNumber') handle - , stateStreamState = PreStream - , stateOpenStreamsCallback = Just callback } - lift $ liftIO $ hSetBuffering handle NoBuffering - lift $ liftIO $ send ("") (Left handle) - threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Left handle) - lift $ liftIO $ putMVar (stateThreadID state) threadID - return Nothing - Left e -> do - let clientState = stateClientState state - ((), clientState') <- lift $ runStateT (callback OpenStreamFailure) clientState - put $ state { stateShouldExit = True } - return $ Just e - - IEC (CESecureWithTLS certificate verifyCertificate callback) -> do - -- CEB.assert (not $ isTLSSecured (stateStreamState state)) (return ()) - let Connected _ handle = stateConnectionState state - lift $ liftIO $ send "" (Left handle) - put $ state { stateStreamState = PreStream - , stateTLSSecureStreamsCallback = Just callback } - return Nothing - --- TODO: Save callback in state. - IEC (CEAuthenticate userName password resource callback) -> do - -- CEB.assert (or [ stateConnectionState state == Connected - -- , stateConnectionState state == TLSSecured ]) (return ()) - -- CEB.assert (stateHandle state /= Nothing) (return ()) - -- let Connected (ServerAddress hostName _) _ = stateConnectionState state - rValue <- lift $ liftIO $ randomIO - put $ state { stateAuthenticationState = AuthenticatingPreChallenge1 userName password resource - , stateAuthenticateCallback = Just callback - , stateSASLRValue = Just (toString rValue) } - lift $ liftIO $ putStrLn $ "__________" ++ ("" ++ (CBBS.encode ("n,,n=" ++ userName ++ ",r=" ++ (toString rValue))) ++ "") - lift $ liftIO $ send ("" ++ (CBBS.encode ("n,,n=" ++ userName ++ ",r=" ++ (toString rValue))) ++ "") handleOrTLSCtx - return Nothing - - IEE (EnumeratorBeginStream from to id ver lang namespace) -> do - put $ state { stateStreamState = PreFeatures (1.0) } - return Nothing - --- IEE (EnumeratorXML (XEFeatures features)) -> do --- let PreFeatures streamProperties = stateStreamState state --- case stateTLSState state of --- NoTLS -> let callback = fromJust $ stateOpenStreamsCallback state in do --- ((), clientState) <- lift $ runStateT (callback $ OpenStreamSuccess streamProperties "TODO") (stateClientState state) --- put $ state { stateClientState = clientState --- , stateStreamState = PostFeatures streamProperties "TODO" } --- return Nothing --- _ -> case stateAuthenticationState state of --- AuthenticatedUnbound _ resource -> do -- TODO: resource --- case resource of --- Nothing -> do --- lift $ liftIO $ send ("") handleOrTLSCtx --- return () --- _ -> do --- lift $ liftIO $ send ("" ++ fromJust resource ++ "") handleOrTLSCtx --- return () --- id <- liftIO $ nextID $ stateIDGenerator state --- lift $ liftIO $ send ("" ++ "") handleOrTLSCtx --- --- -- TODO: Execute callback on iq result --- --- let callback = fromJust $ stateAuthenticateCallback state in do -- TODO: streamProperties "TODO" after success --- ((), clientState) <- lift $ runStateT (callback $ AuthenticateSuccess streamProperties "TODO" "todo") (stateClientState state) -- get proper resource value when moving to iq result --- put $ state { stateClientState = clientState --- , stateStreamState = PostFeatures streamProperties "TODO" } --- state' <- get --- return Nothing --- _ -> do --- let callback = fromJust $ stateTLSSecureStreamsCallback state in do --- ((), clientState) <- lift $ runStateT (callback $ SecureWithTLSSuccess streamProperties "TODO") (stateClientState state) --- put $ state { stateClientState = clientState --- , stateStreamState = PostFeatures streamProperties "TODO" } --- return Nothing --- --- -- TODO: Can we assume that it's safe to start to enumerate on handle when it --- -- might not have exited? --- IEE (EnumeratorXML XEProceed) -> do --- let Connected (ServerAddress hostName _) handle = stateConnectionState state --- tlsCtx <- lift $ liftIO $ do --- gen <- newGenIO :: IO SystemRandom -- TODO: Investigate limitations --- clientContext <- client tlsParams gen handle --- handshake clientContext --- return clientContext --- put $ (defaultState (stateChannel state) (stateThreadID state) (stateClientHandlers state) (stateClientState state) (stateIDGenerator state)) { stateTLSState = PostHandshake tlsCtx, stateConnectionState = (stateConnectionState state), stateTLSSecureStreamsCallback = (stateTLSSecureStreamsCallback state) } --- threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Right tlsCtx) -- double code --- lift $ liftIO $ putStrLn "00000000000000000000000000000000" --- lift $ liftIO $ swapMVar (stateThreadID state) threadID -- return value not used --- lift $ liftIO $ putStrLn "00000000000000000000000000000000" --- lift $ liftIO $ threadDelay 1000000 --- lift $ liftIO $ putStrLn "00000000000000000000000000000000" --- lift $ liftIO $ send ("") (Right tlsCtx) --- lift $ liftIO $ putStrLn "00000000000000000000000000000000" --- return Nothing --- --- IEE (EnumeratorXML (XEChallenge (Chal challenge))) -> do --- lift $ liftIO $ putStrLn challenge --- let Connected (ServerAddress hostName _) _ = stateConnectionState state --- let challenge' = CBBS.decode challenge --- case stateAuthenticationState state of --- AuthenticatingPreChallenge1 userName password resource -> do --- id <- liftIO $ nextID $ stateIDGenerator state --- -- TODO: replyToChallenge --- return () --- AuthenticatingPreChallenge2 userName password resource -> do --- -- This is not the first challenge; [...] --- -- TODO: Can we assume "rspauth"? --- lift $ liftIO $ send "" handleOrTLSCtx --- put $ state { stateAuthenticationState = AuthenticatingPreSuccess userName password resource } --- return () --- return Nothing --- --- -- We have received a SASL "success" message over a secured connection --- -- TODO: Parse the success message? --- -- TODO: ? --- IEE (EnumeratorXML (XESuccess (Succ _))) -> do --- let serverHost = "jonkristensen.com" --- let AuthenticatingPreSuccess userName _ resource = stateAuthenticationState state in do --- lift $ liftIO $ send ("") handleOrTLSCtx --- put $ state { stateAuthenticationState = AuthenticatedUnbound userName resource } --- return Nothing - - IEE EnumeratorDone -> - -- TODO: Exit? - return Nothing - - -- --------------------------------------------------------------------------- - -- XML EVENTS - -- --------------------------------------------------------------------------- - --- -- Ignore id="bind_1" and session IQ result, otherwise create client event --- IEE (EnumeratorXML (XEIQ iqEvent)) -> --- case shouldIgnoreIQ iqEvent of --- True -> --- return Nothing --- False -> do --- let stanzaID' = iqID iqEvent --- let newTimeouts = case stanzaID' of --- Just stanzaID'' -> --- case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of --- True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state) --- False -> (stateTimeoutStanzaIDs state) --- Nothing -> (stateTimeoutStanzaIDs state) --- let iqReceivedFunctions = map (\ x -> iqReceived x) (stateClientHandlers state) --- let functions = map (\ x -> case x of --- Just f -> Just (f iqEvent) --- Nothing -> Nothing) iqReceivedFunctions --- let functions' = case lookup (fromJust $ iqID $ iqEvent) (stateIQCallbacks state) of --- Just f -> (Just (f $ iqEvent)):functions --- Nothing -> functions --- let clientState = stateClientState state --- clientState' <- sendToClient functions' clientState --- put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts } --- return Nothing --- --- -- TODO: Known bug - does not work with PresenceError --- --- IEE (EnumeratorXML (XEPresence (Right presenceEvent))) -> do --- let stanzaID' = presenceID $ presenceEvent --- let newTimeouts = case stanzaID' of --- Just stanzaID'' -> --- case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of --- True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state) --- False -> (stateTimeoutStanzaIDs state) --- Nothing -> (stateTimeoutStanzaIDs state) --- let presenceReceivedFunctions = map (\ x -> presenceReceived x) (stateClientHandlers state) --- let functions = map (\ x -> case x of --- Just f -> Just (f presenceEvent) --- Nothing -> Nothing) presenceReceivedFunctions --- let clientState = stateClientState state -- ClientState s m --- clientState' <- sendToClient functions clientState --- put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts } --- return Nothing --- --- -- TODO: Does not work with message errors --- IEE (EnumeratorXML (XEMessage (Right messageEvent))) -> do --- let stanzaID' = messageID $ messageEvent --- let newTimeouts = case stanzaID' of --- Just stanzaID'' -> --- case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of --- True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state) --- False -> (stateTimeoutStanzaIDs state) --- Nothing -> (stateTimeoutStanzaIDs state) --- let messageReceivedFunctions = map (\ x -> messageReceived x) (stateClientHandlers state) --- let functions = map (\ x -> case x of --- Just f -> Just (f messageEvent) --- Nothing -> Nothing) messageReceivedFunctions --- let clientState = stateClientState state -- ClientState s m --- clientState' <- sendToClient functions clientState --- put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts } --- return Nothing - - IEC (CEPresence presence stanzaCallback timeoutCallback streamErrorCallback) -> do - presence' <- case presenceID $ presence of - Nothing -> do - id <- liftIO $ nextID $ stateIDGenerator state - return $ presence { presenceID = Just (SID id) } - _ -> return presence - case timeoutCallback of - Just (t, timeoutCallback') -> - let stanzaID' = (fromJust $ presenceID $ presence') in do - registerTimeout (stateChannel state) stanzaID' t timeoutCallback' - put $ state { stateTimeoutStanzaIDs = stanzaID':(stateTimeoutStanzaIDs state) } - Nothing -> - return () - let xml = presenceToXML (Right presence') (fromJust $ langTag "en") - lift $ liftIO $ send (elementToString $ Just xml) handleOrTLSCtx - return Nothing - - IEC (CEMessage message stanzaCallback timeoutCallback streamErrorCallback) -> do - message' <- case messageID message of - Nothing -> do - id <- liftIO $ nextID $ stateIDGenerator state - return $ message { messageID = Just (SID id) } - _ -> return message - case timeoutCallback of - Just (t, timeoutCallback') -> - let stanzaID' = (fromJust $ messageID message') in do - registerTimeout (stateChannel state) stanzaID' t timeoutCallback' - put $ state { stateTimeoutStanzaIDs = stanzaID':(stateTimeoutStanzaIDs state) } - Nothing -> - return () - let xml = messageToXML (Right message') (fromJust $ langTag "en") - lift $ liftIO $ send (elementToString $ Just xml) handleOrTLSCtx - return Nothing - - -- TODO: Known bugs until Session rewritten - new ID everytime, callback not called - - IEC (CEIQ iq stanzaCallback timeoutCallback stanzaErrorCallback) -> do - iq' <- do -- case iqID iq of - -- Nothing -> do - id <- liftIO $ nextID $ stateIDGenerator state - return iq - let callback' = fromJust stanzaCallback - put $ state { stateIQCallbacks = (fromJust $ iqID iq, callback'):(stateIQCallbacks state) } - case timeoutCallback of - Just (t, timeoutCallback') -> - let stanzaID' = (fromJust $ iqID iq') in do - registerTimeout (stateChannel state) stanzaID' t timeoutCallback' - put $ state { stateTimeoutStanzaIDs = stanzaID':(stateTimeoutStanzaIDs state) } - Nothing -> - return () - -- TODO: Bind ID to callback - let xml = iqToXML iq' (fromJust $ langTag "en") - lift $ liftIO $ send (elementToString $ Just xml) handleOrTLSCtx - return Nothing - - IEC (CEAction predicate callback) -> do - case predicate of - Just predicate' -> do - result <- runBoolClientCallback predicate' - case result of - True -> do - runUnitClientCallback callback - return Nothing - False -> return Nothing - Nothing -> do - runUnitClientCallback callback - return Nothing - - -- XOEDisconnect -> do - -- -- TODO: Close stream - -- return () - - IET (TimeoutEvent i t c) -> - case i `elem` (stateTimeoutStanzaIDs state) of - True -> do - runUnitClientCallback c - return Nothing - False -> return Nothing - - - e -> do - return Nothing - -- lift $ liftIO $ putStrLn $ "UNCAUGHT EVENT: " ++ (show e) - -- return $ Just (CE.SomeException $ CE.PatternMatchFail "processEvent") - where - -- Assumes handle is set - send :: String -> Either Handle TLSCtx -> IO () - send s o = case o of - Left handle -> do - liftIO $ hPutStr handle $ encodeString $ s - liftIO $ hFlush handle - return () - Right tlsCtx -> do - liftIO $ sendData tlsCtx $ DBLC.pack $ encodeString s - return () - shouldIgnoreIQ :: IQ -> Bool - shouldIgnoreIQ i = case iqPayload i of - Nothing -> False - Just e -> case nameNamespace $ elementName e of - Just x | x == DT.pack "urn:ietf:params:xml:ns:xmpp-bind" -> True - Just x | x == DT.pack "urn:ietf:params:xml:ns:xmpp-session" -> True - Just _ -> False - Nothing -> False - - -registerTimeout :: (ClientState s m, MonadIO m) => Chan (InternalEvent s m) -> StanzaID -> Timeout -> StateT s m () -> StateT (State s m) m () -registerTimeout ch i t ca = do - liftIO $ threadDelay $ t * 1000 - liftIO $ forkIO $ writeChan ch $ IET (TimeoutEvent i t ca) - return () - - -runBoolClientCallback :: (ClientState s m, MonadIO m) => StateT s m Bool -> StateT (State s m) m Bool -runBoolClientCallback c = do - state <- get - let clientState = stateClientState state - (bool, clientState') <- lift $ runStateT c clientState - put $ state { stateClientState = clientState' } - return bool - - -runUnitClientCallback :: (ClientState s m, MonadIO m) => StateT s m () -> StateT (State s m) m () -runUnitClientCallback c = do - state <- get - let clientState = stateClientState state - ((), clientState') <- lift $ runStateT c clientState - put $ state { stateClientState = clientState' } - - -sendToClient :: (MonadIO m, ClientState s m) => [Maybe (StateT s m Bool)] -> s -> (StateT (State s m) m) s -sendToClient [] s = return s -sendToClient (Nothing:fs) s = sendToClient fs s -sendToClient ((Just f):fs) s = do - (b, s') <- lift $ runStateT f s - case b of - True -> return s' - False -> sendToClient fs s' diff --git a/Network/XMPP/Stanza.hs b/Network/XMPP/Stanza.hs deleted file mode 100644 --- a/Network/XMPP/Stanza.hs +++ /dev/null @@ -1,188 +0,0 @@ --- Copyright © 2010-2011 Jon Kristensen. See the LICENSE file in the Pontarius --- XMPP distribution for more details. - -{-# OPTIONS_HADDOCK hide #-} - --- The stanza record types are generally pretty convenient to work with. --- However, due to the fact that an "IQ" can be both an "IQRequest" and an --- "IQResponse" we provide some helper functions in this module that work on --- both types. --- --- We also provide functions to create a new stanza ID generator, and to --- generate new IDs. - -module Network.XMPP.Stanza ( -iqID, -iqFrom, -iqTo, -iqLangTag, -iqPayload, -iqPayloadNamespace, -iqRequestPayloadNamespace, -iqResponsePayloadNamespace, -idGenerator, -nextID -) where - -import Network.XMPP.Address -import Network.XMPP.Types - -import Data.IORef (atomicModifyIORef, newIORef) -import Data.XML.Types (Element, elementName, nameNamespace) -import Data.Text (unpack) - - --- | --- Returns the @StanzaID@ value of the @IQ@, if any. - -iqID :: IQ -> Maybe StanzaID - -iqID (Left req) = iqRequestID req -iqID (Right res) = iqResponseID res - - --- TODO: Maybe? - -iqResponseID :: IQResponse -> Maybe StanzaID - -iqResponseID (Left err) = iqErrorID err -iqResponseID (Right res) = iqResultID res - - --- | --- Returns the @From@ @JID@ value of the @IQ@, if any. - -iqFrom :: IQ -> Maybe From - -iqFrom (Left req) = iqRequestFrom req -iqFrom (Right res) = iqResponseFrom res - - --- | --- Returns the @To@ @JID@ value of the @IQ@, if any. - -iqTo :: IQ -> Maybe To - -iqTo (Left req) = iqRequestTo req -iqTo (Right res) = iqResponseTo res - - --- | --- Returns the @XMLLang@ value of the @IQ@, if any. - -iqLangTag :: IQ -> LangTag - -iqLangTag (Left req) = iqRequestLangTag req -iqLangTag (Right res) = iqResponseLangTag res - - -iqResponseLangTag :: IQResponse -> LangTag - -iqResponseLangTag (Left err) = iqErrorLangTag err -iqResponseLangTag (Right res) = iqResultLangTag res - - -iqResponseFrom :: IQResponse -> Maybe From - -iqResponseFrom (Left err) = iqErrorFrom err -iqResponseFrom (Right res) = iqResultFrom res - - -iqResponseTo :: IQResponse -> Maybe To - -iqResponseTo (Left err) = iqErrorTo err -iqResponseTo (Right res) = iqResultTo res - - - --- | --- Returns the @Element@ payload value of the @IQ@, if any. If the IQ in --- question is of the "request" type, use @iqRequestPayload@ instead. - -iqPayload :: IQ -> Maybe Element - -iqPayload (Left req) = Just (iqRequestPayload req) -iqPayload (Right res) = iqResponsePayload res - - -iqResponsePayload :: IQResponse -> Maybe Element - -iqResponsePayload (Left err) = iqErrorPayload err -iqResponsePayload (Right res) = iqResultPayload res - - --- | --- Returns the namespace of the element of the @IQ@, if any. - -iqPayloadNamespace :: IQ -> Maybe String - -iqPayloadNamespace i = case iqPayload i of - Nothing -> Nothing - Just p -> case nameNamespace $ elementName p of - Nothing -> Nothing - Just n -> Just (unpack n) - - --- | --- Returns the namespace of the element of the @IQRequest@, if any. - -iqRequestPayloadNamespace :: IQRequest -> Maybe String - -iqRequestPayloadNamespace i = let p = iqRequestPayload i in - case nameNamespace $ elementName p of - Nothing -> Nothing - Just n -> Just (unpack n) - - --- | --- Returns the namespace of the element of the @IQRequest@, if any. - -iqResponsePayloadNamespace :: IQResponse -> Maybe String - -iqResponsePayloadNamespace i = case iqResponsePayload i of - Nothing -> Nothing - Just p -> case nameNamespace $ elementName p of - Nothing -> Nothing - Just n -> Just (unpack n) - - --- | --- Creates a new stanza "IDGenerator". Internally, it will maintain an infinite --- list of stanza IDs ('[\'a\', \'b\', \'c\'...]'). - -idGenerator :: String -> IO IDGenerator - -idGenerator p = newIORef (ids p) >>= \ ioRef -> return $ IDGenerator ioRef - - --- | --- Extracts an ID from the "IDGenerator", and updates the generators internal --- state so that the same ID will not be generated again. - -nextID :: IDGenerator -> IO String - -nextID g = let IDGenerator ioRef = g - in atomicModifyIORef ioRef (\ (i:is) -> (is, i)) - - --- Generates an infinite and predictable list of IDs, all beginning with the --- provided prefix. - -ids :: String -> [String] - --- Adds the prefix to all combinations of IDs (ids'). -ids p = map (\ id -> p ++ id) ids' - where - - -- Generate all combinations of IDs, with increasing length. - ids' :: [String] - ids' = concatMap ids'' [1..] - - -- Generates all combinations of IDs with the given length. - ids'' :: Integer -> [String] - ids'' 0 = [""] - ids'' l = [x:xs | x <- repertoire, xs <- ids'' (l - 1)] - - -- Characters allowed in IDs. - repertoire :: String - repertoire = ['a'..'z'] diff --git a/Network/XMPP/Stream.hs b/Network/XMPP/Stream.hs deleted file mode 100644 --- a/Network/XMPP/Stream.hs +++ /dev/null @@ -1,525 +0,0 @@ --- Copyright © 2010-2011 Jon Kristensen. See the LICENSE file in the Pontarius --- XMPP distribution for more details. - -{-# OPTIONS_HADDOCK hide #-} - -{-# LANGUAGE OverloadedStrings #-} - -module Network.XMPP.Stream ( -xmlEnumerator, -presenceToXML, -iqToXML, -messageToXML, -parsePresence, -parseIQ, -parseMessage, -langTag, -versionFromString, -versionFromNumbers -) where - -import Network.XMPP.Types hiding (Continue) - -import Prelude hiding (null) - -import Control.Concurrent.Chan (Chan, writeChan) -import Control.Exception.Base (SomeException) -import Control.Monad.IO.Class (liftIO) -import Data.ByteString.Lazy (null, toChunks) -import Data.Enumerator ((>>==), ($$), Iteratee (..), Enumeratee, Step (..), Enumerator (..), Stream (Chunks), returnI, joinI, run) -import Data.Enumerator.Binary (enumHandle) -import Data.Maybe (fromJust, isJust) -import Data.Text (pack, unpack) -import Data.XML.Types (Content (..), Document (..), Element (..), Event (..), Name (..), Node (..)) -import GHC.IO.Handle (Handle) -import Network.TLS (TLSCtx, recvData) -import Text.Parsec (char, count, digit, eof, many, many1, oneOf, parse) -import Text.Parsec.ByteString (GenParser) -import Text.XML.Enumerator.Document (fromEvents) -import Text.XML.Enumerator.Parse (parseBytes, decodeEntities) - -import qualified Data.ByteString as DB (ByteString) -import qualified Data.ByteString.Char8 as DBC (pack) -import qualified Data.Enumerator.List as DEL (head) - - --- 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 $$ eventConsumer c [] 0 - Right tlsCtx -> run $ enumTLS tlsCtx $$ joinI $ - parseBytes decodeEntities $$ eventConsumer c [] 0 - 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 - -- TODO: Type? - enumTLS :: TLSCtx -> Enumerator DB.ByteString IO b - enumTLS c s = loop c s - - -- TODO: Type? - loop :: TLSCtx -> Step DB.ByteString IO b -> Iteratee DB.ByteString IO b - loop c (Continue k) = do - d <- recvData c - case null d of - True -> loop c (Continue k) - False -> k (Chunks $ toChunks d) >>== loop c - loop _ step = returnI step - - --- Consumes XML events from the input stream, accumulating as necessary, and --- sends the proper events through the channel. The second parameter should be --- initialized to [] (no events) and the third to 0 (zeroth XML level). - -eventConsumer :: Chan (InternalEvent s m) -> [Event] -> Int -> - Iteratee Event IO (Maybe Event) - --- open event received. - -eventConsumer chan [EventBeginElement (Name localName namespace prefixName) attribs] 0 - | localName == pack "stream" && isJust prefixName && fromJust prefixName == pack "stream" = do - liftIO $ writeChan chan $ IEE $ EnumeratorBeginStream from to id ver lang ns - eventConsumer chan [] 1 - where - from = case lookup "from" attribs of Nothing -> Nothing; Just fromAttrib -> Just $ show fromAttrib - to = case lookup "to" attribs of Nothing -> Nothing; Just toAttrib -> Just $ show toAttrib - id = case lookup "id" attribs of Nothing -> Nothing; Just idAttrib -> Just $ show idAttrib - ver = case lookup "version" attribs of Nothing -> Nothing; Just verAttrib -> Just $ show verAttrib - lang = case lookup "xml:lang" attribs of Nothing -> Nothing; Just langAttrib -> Just $ show langAttrib - ns = case namespace of Nothing -> Nothing; Just namespaceAttrib -> Just $ unpack namespaceAttrib - --- close event received. - -eventConsumer chan [EventEndElement name] 1 - | namePrefix name == Just (pack "stream") && nameLocalName name == pack "stream" = do - liftIO $ writeChan chan $ IEE $ EnumeratorEndStream - return Nothing - --- Ignore EventDocumentBegin event. - -eventConsumer chan [EventBeginDocument] 0 = eventConsumer chan [] 0 - --- We have received a complete first-level XML element. Process the accumulated --- values into an first-level element event. - -eventConsumer chan ((EventEndElement e):es) 1 = do - liftIO $ writeChan chan $ IEE $ EnumeratorFirstLevelElement $ eventsToElement $ reverse ((EventEndElement e):es) - eventConsumer chan [] 1 - --- Normal condition - accumulate the event. - -eventConsumer chan events level = do - event <- DEL.head - case event of - Just event' -> let level' = case event' of - EventBeginElement _ _ -> level + 1 - EventEndElement _ -> level - 1 - _ -> level - in eventConsumer chan (event':events) level' - Nothing -> eventConsumer chan events level - - -eventsToElement :: [Event] -> Either SomeException Element - -eventsToElement e = do - r <- run $ eventsEnum $$ fromEvents - case r of Right doc -> Right $ documentRoot doc; Left ex -> Left ex - where - -- TODO: Type? - eventsEnum (Continue k) = k $ Chunks e - eventsEnum step = returnI step - - --- Sending stanzas is done through functions, where LangTag is Maybe. - - --- Generates an XML element for a message stanza. The language tag provided is --- the default language of the stream. - -messageToXML :: InternalMessage -> LangTag -> Element - --- Non-error message. - -messageToXML (Right m) streamLang = Element "message" attribs nodes - - where - - -- Has the stanza attributes and the message type. - attribs :: [(Name, [Content])] - attribs = stanzaAttribs (messageID m) (messageFrom m) (messageTo m) stanzaLang ++ - [("type", [ContentText $ pack $ show $ messageType m])] - - -- Has an arbitrary number of elements as children. - nodes :: [Node] - nodes = map (\ x -> NodeElement x) (messagePayload m) - - stanzaLang :: Maybe LangTag - stanzaLang = stanzaLang' streamLang $ messageLangTag m - --- Presence error. - -messageToXML (Left m) streamLang = Element "message" attribs nodes - - where - - -- Has the stanza attributes and the "error" presence type. - attribs :: [(Name, [Content])] - attribs = stanzaAttribs (messageErrorID m) (messageErrorFrom m) (messageErrorTo m) - stanzaLang ++ [("type", [ContentText $ pack "error"])] - - -- Has the error element stanza as its child. - -- TODO: Include sender XML here? - nodes :: [Node] - nodes = [NodeElement $ errorElem streamLang stanzaLang $ messageErrorStanzaError m] - - -- The stanza language tag, if it's different from the stream language tag. - stanzaLang :: Maybe LangTag - stanzaLang = stanzaLang' streamLang $ messageErrorLangTag m - - --- Generates an XML element for a presence stanza. The language tag provided is --- the default language of the stream. - -presenceToXML :: InternalPresence -> LangTag -> Element - --- Non-error presence. - -presenceToXML (Right p) streamLang = Element "presence" attribs nodes - - where - - -- Has the stanza attributes and the presence type. - attribs :: [(Name, [Content])] - attribs = stanzaAttribs (presenceID p) (presenceFrom p) (presenceTo p) stanzaLang ++ - typeAttrib - - -- Has an arbitrary number of elements as children. - nodes :: [Node] - nodes = map (\ x -> NodeElement x) (presencePayload p) - - stanzaLang :: Maybe LangTag - stanzaLang = stanzaLang' streamLang $ presenceLangTag p - - typeAttrib :: [(Name, [Content])] - typeAttrib = case presenceType p of Nothing -> []; Just presenceType' -> [("type", [ContentText $ pack $ show presenceType'])] - --- Presence error. - -presenceToXML (Left p) streamLang = Element "presence" attribs nodes - - where - - -- Has the stanza attributes and the "error" presence type. - attribs :: [(Name, [Content])] - attribs = stanzaAttribs (presenceErrorID p) (presenceErrorFrom p) (presenceErrorTo p) - stanzaLang ++ [("type", [ContentText $ pack "error"])] - - -- Has the error element stanza as its child. - -- TODO: Include sender XML here? - nodes :: [Node] - nodes = [NodeElement $ errorElem streamLang stanzaLang $ presenceErrorStanzaError p] - - -- The stanza language tag, if it's different from the stream language tag. - stanzaLang :: Maybe LangTag - stanzaLang = stanzaLang' streamLang $ presenceErrorLangTag p - - --- Generates an XML element for a presence stanza. The language tag provided is --- the default language of the stream. - -iqToXML :: IQ -> LangTag -> Element - --- Request IQ. - -iqToXML (Left i) streamLang = Element "iq" attribs nodes - - where - - -- Has the stanza attributes and the IQ request type (`get' or `set'). - attribs :: [(Name, [Content])] - attribs = stanzaAttribs (iqRequestID i) (iqRequestFrom i) (iqRequestTo i) - stanzaLang ++ typeAttrib - - -- Has exactly one payload child element. - nodes :: [Node] - nodes = [NodeElement $ iqRequestPayload i] - - -- The stanza language tag, if it's different from the stream language tag. - stanzaLang :: Maybe LangTag - stanzaLang = stanzaLang' streamLang $ iqRequestLangTag i - - -- The required type attribute. - typeAttrib :: [(Name, [Content])] - typeAttrib = [("type", [ContentText $ pack $ show $ iqRequestType i])] - --- Response result IQ. - -iqToXML (Right (Right i)) streamLang = Element "iq" attribs nodes - - where - - -- Has the stanza attributes and the IQ `result' type. - attribs :: [(Name, [Content])] - attribs = stanzaAttribs (iqResultID i) (iqResultFrom i) (iqResultTo i) - stanzaLang ++ typeAttrib - - -- Has one or zero payload child elements. - nodes :: [Node] - nodes = case iqResultPayload i of Nothing -> []; Just payloadElem -> [NodeElement payloadElem] - - stanzaLang :: Maybe LangTag - stanzaLang = stanzaLang' streamLang $ iqResultLangTag i - - -- The required type attribute. - typeAttrib :: [(Name, [Content])] - typeAttrib = [("type", [ContentText $ pack "result"])] - --- Response error IQ. - -iqToXML (Right (Left i)) streamLang = Element "iq" attribs nodes - - where - - -- Has the stanza attributes and the presence type. - attribs :: [(Name, [Content])] - attribs = stanzaAttribs (iqErrorID i) (iqErrorFrom i) (iqErrorTo i) stanzaLang ++ - typeAttrib - - -- Has an optional elements as child. - nodes :: [Node] - nodes = case iqErrorPayload i of Nothing -> []; Just payloadElem -> [NodeElement payloadElem] - - stanzaLang :: Maybe LangTag - stanzaLang = stanzaLang' streamLang $ iqErrorLangTag i - - typeAttrib :: [(Name, [Content])] - typeAttrib = [("type", [ContentText $ pack "error"])] - - --- Creates the error element that is common for all stanzas. - -errorElem :: LangTag -> Maybe LangTag -> StanzaError -> Element - -errorElem streamLang stanzaLang stanzaError = Element "error" typeAttrib - ([defCondElem] ++ textElem ++ appSpecCondElem) - - where - - -- The required stanza error type. - typeAttrib :: [(Name, [Content])] - typeAttrib = [("type", [ContentText $ pack $ show $ stanzaErrorType stanzaError])] - - -- The required defined condition element. - defCondElem :: Node - defCondElem = NodeElement $ Element (Name (pack $ show $ stanzaErrorCondition stanzaError) (Just $ pack "urn:ietf:params:xml:ns:xmpp-stanzas") Nothing) [] [] - - - -- The optional text element. - textElem :: [Node] - textElem = case stanzaErrorText stanzaError of - Nothing -> [] - Just (textLang, text) -> - [NodeElement $ Element "{urn:ietf:params:xml:ns:xmpp-stanzas}text" - (langTagAttrib $ childLang streamLang [stanzaLang, fst $ fromJust $ stanzaErrorText stanzaError]) - [NodeContent $ ContentText $ pack text]] - - -- The optional application specific condition element. - appSpecCondElem :: [Node] - appSpecCondElem = case stanzaErrorApplicationSpecificCondition stanzaError of - Nothing -> [] - Just elem -> [NodeElement elem] - - --- Generates the element attribute for an optional language tag. - -langTagAttrib :: Maybe LangTag -> [(Name, [Content])] - -langTagAttrib lang = case lang of Nothing -> []; Just lang' -> [("xml:lang", [ContentText $ pack $ show lang'])] - - -stanzaLang' :: LangTag -> LangTag -> Maybe LangTag - -stanzaLang' streamLang stanzaLang | streamLang == stanzaLang = Nothing - | otherwise = Just stanzaLang - - --- Finds the language tag to set on the current element, if any. Makes sure that --- language tags are not repeated unnecessarily (like on a child element, when --- the parent has it). The first parameter is the stream language tag, and the --- list of optional language tags are ordered in their XML element child --- sequence, parent first, starting with the stanza language tag. - -childLang :: LangTag -> [Maybe LangTag] -> Maybe LangTag - -childLang streamLang optLangTags - - -- The current element does not have a language tag - set nothing. - | (head $ reverse optLangTags) == Nothing = Nothing - - -- All optional language tags are Nothing - set nothing. - | length langTags == 1 = Nothing - - -- The language tag of this element is the same as the closest parent with a - -- language tag - set nothing. - | (head langTags) == (head $ tail langTags) = Nothing - - -- Set the language tag. - | otherwise = Just $ head langTags - - where - - -- Contains the chain of language tags in descending priority order. - -- Contains at least one element - the stream language tag. - langTags = reverse $ [streamLang] ++ (map fromJust $ filter (\ l -> isJust l) optLangTags) - - --- Creates the attributes common for all stanzas. - -stanzaAttribs :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe LangTag -> [(Name, [Content])] - -stanzaAttribs i f t l = if isJust $ i then [("id", [ContentText $ pack $ show $ fromJust i])] else [] ++ - if isJust $ f then [("from", [ContentText $ pack $ show $ fromJust f])] else [] ++ - if isJust $ t then [("to", [ContentText $ pack $ show $ fromJust t])] else [] ++ - if isJust $ l then [("xml:lang", [ContentText $ pack $ show l])] else [] - - -parseIQ :: Element -> IQ - -parseIQ = parseIQ - - -parsePresence :: Element -> InternalPresence - -parsePresence = parsePresence - - -parseMessage :: Element -> InternalMessage - -parseMessage = parseMessage - - --- Converts a string to a PresenceType. Nothing means convertion error, Just --- Nothing means the presence error type, and Just $ Just is the PresenceType. - -stringToPresenceType :: String -> Maybe (Maybe PresenceType) - -stringToPresenceType "probe" = Just $ Just Probe -stringToPresenceType "unavailable" = Just $ Just Unavailable -stringToPresenceType "subscribe" = Just $ Just Subscribe -stringToPresenceType "subscribed" = Just $ Just Subscribed -stringToPresenceType "unsubscribe" = Just $ Just Unsubscribe -stringToPresenceType "unsubscribed" = Just $ Just Unsubscribed -stringToPresenceType "error" = Just Nothing -stringToPresenceType _ = Nothing - - --- Converts a Maybe MessageType to a string. Nothing means "error". - -presenceTypeToString :: Maybe PresenceType -> String - -presenceTypeToString (Just Unavailable) = "unavailable" -presenceTypeToString (Just Probe) = "probe" -presenceTypeToString Nothing = "error" -presenceTypeToString (Just Subscribe) = "subscribe" -presenceTypeToString (Just Subscribed) = "subscribed" -presenceTypeToString (Just Unsubscribe) = "unsubscribe" -presenceTypeToString (Just Unsubscribed) = "unsubscribed" - - --- Converts a string to a MessageType. Nothing means convertion error, Just --- Nothing means the message error type, and Just $ Just is the MessageType. - -stringToMessageType :: String -> Maybe (Maybe MessageType) - -stringToMessageType "chat" = Just $ Just Chat -stringToMessageType "error" = Just $ Nothing -stringToMessageType "groupchat" = Just $ Just Groupchat -stringToMessageType "headline" = Just $ Just Headline -stringToMessageType "normal" = Just $ Just Normal -stringToMessageType _ = Nothing - - --- Converts a Maybe MessageType to a string. Nothing means "error". - -messageTypeToString :: Maybe MessageType -> String - -messageTypeToString (Just Chat) = "chat" -messageTypeToString Nothing = "error" -messageTypeToString (Just Groupchat) = "groupchat" -messageTypeToString (Just Headline) = "headline" -messageTypeToString (Just Normal) = "normal" - - --- Converts a "." numeric version number to a "Version" object. - -versionFromString :: String -> Maybe Version - -versionFromString s = case parse version "" (DBC.pack s) of - Right version -> Just version - Left _ -> Nothing - - --- Constructs a "Version" based on the major and minor version numbers. - -versionFromNumbers :: Integer -> Integer -> Version - -versionFromNumbers major minor = Version major minor - - -version :: GenParser Char st Version - -version = do - - -- Read numbers, a dot, more numbers, and end-of-file. - major <- many1 digit - char '.' - minor <- many1 digit - eof - return $ Version (read major) (read minor) - - --- | --- Parses, validates, and possibly constructs a "LangTag" object. - -langTag :: String -> Maybe LangTag - -langTag s = case parse languageTag "" (DBC.pack s) of - Right tag -> Just tag - Left _ -> Nothing - - --- Parses a language tag as defined by RFC 1766 and constructs a LangTag object. - -languageTag :: GenParser Char st LangTag - -languageTag = do - - -- Read until we reach a '-' character, or EOF. This is the `primary tag'. - primTag <- tag - - -- Read zero or more subtags. - subTags <- subtags - eof - - return $ LangTag primTag subTags - where - - subtags :: GenParser Char st [String] - subtags = many $ do - char '-' - subtag <- tag - return subtag - - tag :: GenParser Char st String - tag = do - a <- many1 $ oneOf tagChars - return a - - tagChars :: [Char] - tagChars = ['a'..'z'] ++ ['A'..'Z'] diff --git a/Network/XMPP/TLS.hs b/Network/XMPP/TLS.hs deleted file mode 100644 --- a/Network/XMPP/TLS.hs +++ /dev/null @@ -1,30 +0,0 @@ --- Copyright © 2010-2011 Jon Kristensen. See the LICENSE file in the Pontarius --- XMPP distribution for more details. - --- TODO: TLS12 when supported in tls; TODO: TLS11 results in a read error - bug? --- TODO: cipher_AES128_SHA1 = TLS_RSA_WITH_AES_128_CBC_SHA? --- TODO: Compression? --- TODO: Validate certificate - -{-# OPTIONS_HADDOCK hide #-} - -module Network.XMPP.TLS (tlsParams) where - -import Network.TLS (TLSCertificateUsage (CertificateUsageAccept), - TLSParams (..), Version (SSL3, TLS10, TLS11), - defaultLogging, nullCompression) -import Network.TLS.Extra (cipher_AES128_SHA1) - - -tlsParams :: TLSParams - -tlsParams = TLSParams { pConnectVersion = TLS10 - , pAllowedVersions = [SSL3, TLS10,TLS11] - , pCiphers = [cipher_AES128_SHA1] - , pCompressions = [nullCompression] - , pWantClientCert = False -- Used for servers - , pUseSecureRenegotiation = False -- No renegotiation - , pCertificates = [] -- TODO - , pLogging = defaultLogging -- TODO - , onCertificatesRecv = \ certificate -> - return CertificateUsageAccept } diff --git a/Network/XMPP/Types.hs b/Network/XMPP/Types.hs deleted file mode 100644 --- a/Network/XMPP/Types.hs +++ /dev/null @@ -1,588 +0,0 @@ --- Copyright © 2010-2011 Jon Kristensen. See the LICENSE file in the Pontarius --- XMPP distribution for more details. - -{-# OPTIONS_HADDOCK hide #-} - -{-# LANGUAGE MultiParamTypeClasses #-} - -module Network.XMPP.Types ( -StanzaID (..), -From, -To, -IQ, -IQRequest (..), -IQResponse (..), -Message (..), -MessageType (..), -Presence (..), -PresenceType (..), -StanzaError (..), -StanzaErrorType (..), -StanzaErrorCondition (..), - HostName - , Password - , PortNumber - , Resource - , UserName, -EnumeratorEvent (..), -Challenge (..), -Success (..), -TLSState (..), -Address (..), -Localpart, -Domainpart, -Resourcepart, -LangTag (..), -InternalEvent (..), -ConnectionState (..), -ClientEvent (..), -StreamState (..), -AuthenticationState (..), -ConnectResult (..), -OpenStreamResult (..), -SecureWithTLSResult (..), -AuthenticateResult (..), -ServerAddress (..), -XMPPError (..), -Timeout, -TimeoutEvent (..), -StreamError (..), -IDGenerator (..), -Version (..), -IQError (..), -IQResult (..), -IQRequestType (..), -PresenceError (..), -InternalPresence (..), -InternalMessage (..), -MessageError (..), -) 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 hiding (Version) -import Network.TLS.Cipher - -import qualified Control.Monad.Error as CME - -import Data.IORef - -import Data.Certificate.X509 (X509) - -import Data.List (intersperse) -import Data.Char (toLower) - -import Control.Exception.Base (SomeException) - --- ============================================================================= --- STANZA TYPES --- ============================================================================= - - --- TODO: Would a Stanza class such as the one below be useful sometimes? --- --- class Stanza a where --- stanzaID :: a -> Maybe StanzaID --- stanzaFrom :: a -> Maybe From --- stanzaTo :: a -> Maybe To --- stanzaXMLLang :: a -> Maybe XMLLang - - --- | --- The StanzaID type wraps a string of random characters that in Pontarius XMPP --- is guaranteed to be unique for the XMPP session. Clients can add a string --- prefix for the IDs to guarantee that they are unique in a larger context by --- specifying the stanzaIDPrefix setting. TODO - -data StanzaID = SID String deriving (Eq, Show) - - --- | --- @From@ is a readability type synonym for @Address@. - -type From = Address - - --- | --- @To@ is a readability type synonym for @Address@. - -type To = Address - - --- | --- An Info/Query (IQ) stanza is either of the type "request" ("get" or "set") or --- "response" ("result" or "error"). The @IQ@ type wraps these two sub-types. - -type IQ = Either IQRequest IQResponse - - --- | --- A "request" Info/Query (IQ) stanza is one with either "get" or "set" as type. --- They are guaranteed to always contain a payload. - -data IQRequest = IQRequest { iqRequestID :: Maybe StanzaID - , iqRequestFrom :: Maybe From - , iqRequestTo :: Maybe To - , iqRequestLangTag :: LangTag - , iqRequestType :: IQRequestType - , iqRequestPayload :: Element } - deriving (Show) - - -data IQRequestType = Get | Set deriving (Show) - - -type IQResponse = Either IQError IQResult - - -data IQResult = IQResult { iqResultID :: Maybe StanzaID - , iqResultFrom :: Maybe From - , iqResultTo :: Maybe To - , iqResultLangTag :: LangTag - , iqResultPayload :: Maybe Element } - deriving (Show) - - -data IQError = IQError { iqErrorID :: Maybe StanzaID - , iqErrorFrom :: Maybe From - , iqErrorTo :: Maybe To - , iqErrorLangTag :: LangTag - , iqErrorPayload :: Maybe Element - , iqErrorStanzaError :: StanzaError } - deriving (Show) - - --- | --- The message stanza - either a message or a message error. - -data Message = Message { messageID :: Maybe StanzaID - , messageFrom :: Maybe From - , messageTo :: Maybe To - , messageLangTag :: LangTag - , messageType :: MessageType - , messagePayload :: [Element] } - deriving (Show) - - -data MessageError = MessageError { messageErrorID :: Maybe StanzaID - , messageErrorFrom :: Maybe From - , messageErrorTo :: Maybe To - , messageErrorLangTag :: LangTag - , messageErrorPayload :: Maybe [Element] - , messageErrorStanzaError :: StanzaError } - deriving (Show) - - -type InternalMessage = Either MessageError Message - - --- | --- @MessageType@ holds XMPP message types as defined in XMPP-IM. @Normal@ is the --- default message type. The "error" message type is left out as errors are --- using @MessageError@. - -data MessageType = Chat | - Groupchat | - Headline | - Normal deriving (Eq) - - -instance Show MessageType where - show Chat = "chat" - show Groupchat = "groupchat" - show Headline = "headline" - show Normal = "normal" - - --- | --- The presence stanza. It is used for both originating messages and replies. --- For presence errors, see "PresenceError". - -data Presence = Presence { presenceID :: Maybe StanzaID - , presenceFrom :: Maybe From - , presenceTo :: Maybe To - , presenceLangTag :: LangTag - , presenceType :: Maybe PresenceType - , presencePayload :: [Element] } - deriving (Show) - - -data PresenceError = PresenceError { presenceErrorID :: Maybe StanzaID - , presenceErrorFrom :: Maybe From - , presenceErrorTo :: Maybe To - , presenceErrorLangTag :: LangTag - , presenceErrorPayload :: Maybe [Element] - , presenceErrorStanzaError :: StanzaError } - deriving (Show) - - -type InternalPresence = Either PresenceError Presence - - --- | --- @PresenceType@ holds XMPP presence types. The "error" message type is left --- out as errors are using @PresenceError@. - -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 - Unavailable deriving (Eq) - - -instance Show PresenceType where - show Subscribe = "subscribe" - show Subscribed = "subscribed" - show Unsubscribe = "unsubscribe" - show Unsubscribed = "unsubscribed" - show Probe = "probe" - show Unavailable = "unavailable" - - --- | --- All stanzas (IQ, message, presence) can cause errors, which in the XMPP --- stream looks like . These errors are --- wrapped in the @StanzaError@ type. - --- Sender XML is optional and is not included. - -data StanzaError = StanzaError { stanzaErrorType :: StanzaErrorType - , stanzaErrorCondition :: StanzaErrorCondition - , stanzaErrorText :: Maybe (Maybe LangTag, String) - , stanzaErrorApplicationSpecificCondition :: - Maybe Element } deriving (Eq, Show) - - --- | --- @StanzaError@s always have one of these types. - -data StanzaErrorType = Cancel | -- ^ Error is unrecoverable - do not retry - Continue | -- ^ Conditition was a warning - proceed - Modify | -- ^ Change the data and retry - Auth | -- ^ Provide credentials and retry - Wait -- ^ Error is temporary - wait and retry - deriving (Eq) - - -instance Show StanzaErrorType where - show Cancel = "cancel" - show Continue = "continue" - show Modify = "modify" - show Auth = "auth" - show Wait = "wait" - - --- | --- Stanza errors are accommodated with one of the error conditions listed below. - -data StanzaErrorCondition = BadRequest | -- ^ Malformed XML - Conflict | -- ^ Resource or session - -- with name already - -- exists - FeatureNotImplemented | - Forbidden | -- ^ Insufficient - -- permissions - Gone | -- ^ Entity can no longer - -- be contacted at this - -- address - InternalServerError | - ItemNotFound | - JIDMalformed | - NotAcceptable | -- ^ Does not meet policy - -- criteria - NotAllowed | -- ^ No entity may perform - -- this action - NotAuthorized | -- ^ Must provide proper - -- credentials - PaymentRequired | - RecipientUnavailable | -- ^ Temporarily - -- unavailable - Redirect | -- ^ Redirecting to other - -- entity, usually - -- temporarily - RegistrationRequired | - RemoteServerNotFound | - RemoteServerTimeout | - ResourceConstraint | -- ^ Entity lacks the - -- necessary system - -- resources - ServiceUnavailable | - SubscriptionRequired | - UndefinedCondition | -- ^ Application-specific - -- condition - UnexpectedRequest -- ^ Badly timed request - deriving (Eq) - - -instance Show StanzaErrorCondition where - show BadRequest = "bad-request" - show Conflict = "conflict" - show FeatureNotImplemented = "feature-not-implemented" - show Forbidden = "forbidden" - show Gone = "gone" - show InternalServerError = "internal-server-error" - show ItemNotFound = "item-not-found" - show JIDMalformed = "jid-malformed" - show NotAcceptable = "not-acceptable" - show NotAllowed = "not-allowed" - show NotAuthorized = "not-authorized" - show PaymentRequired = "payment-required" - show RecipientUnavailable = "recipient-unavailable" - show Redirect = "redirect" - show RegistrationRequired = "registration-required" - show RemoteServerNotFound = "remote-server-not-found" - show RemoteServerTimeout = "remote-server-timeout" - show ResourceConstraint = "resource-constraint" - show ServiceUnavailable = "service-unavailable" - show SubscriptionRequired = "subscription-required" - show UndefinedCondition = "undefined-condition" - show UnexpectedRequest = "unexpected-request" - - - --- ============================================================================= --- OTHER STUFF --- ============================================================================= - - -data SASLFailure = SASLFailure { saslFailureCondition :: SASLError - , saslFailureText :: Maybe String } -- TODO: XMLLang - - -data SASLError = -- SASLAborted | -- Client aborted - should not happen - SASLAccountDisabled | -- ^ The account has been temporarily - -- disabled - SASLCredentialsExpired | -- ^ The authentication failed because - -- the credentials have expired - SASLEncryptionRequired | -- ^ The mechanism requested cannot be - -- used the confidentiality and - -- integrity of the underlying - -- stream is protected (typically - -- with TLS) - -- SASLIncorrectEncoding | -- The base64 encoding is incorrect - -- - should not happen - -- SASLInvalidAuthzid | -- The authzid has an incorrect format, - -- or the initiating entity does not - -- have the appropriate permissions to - -- authorize that ID - SASLInvalidMechanism | -- ^ The mechanism is not supported by - -- the receiving entity - -- SASLMalformedRequest | -- Invalid syntax - should not happen - SASLMechanismTooWeak | -- ^ The receiving entity policy - -- requires a stronger mechanism - SASLNotAuthorized (Maybe String) | -- ^ Invalid credentials - -- provided, or some - -- generic authentication - -- failure has occurred - SASLTemporaryAuthFailure -- ^ There receiving entity reported a - -- temporary error condition; the - -- initiating entity is recommended - -- to try again later - - -instance Eq ConnectionState where - Disconnected == Disconnected = True - (Connected p h) == (Connected p_ h_) = p == p_ && h == h_ - -- (ConnectedPostFeatures s p h t) == (ConnectedPostFeatures s p h t) = True - -- (ConnectedAuthenticated s p h t) == (ConnectedAuthenticated s p h t) = True - _ == _ = False - -data XMPPError = UncaughtEvent deriving (Eq, Show) - -instance CME.Error XMPPError where - strMsg "UncaughtEvent" = UncaughtEvent - - --- | Readability type for host name Strings. - -type HostName = String -- This is defined in Network as well - - --- | Readability type for port number Integers. - -type PortNumber = Integer -- We use N(etwork).PortID (PortNumber) internally - - --- | Readability type for user name Strings. - -type UserName = String - - --- | Readability type for password Strings. - -type Password = String - - --- | Readability type for (Address) resource identifier Strings. - -type Resource = String - - --- An XMLEvent is triggered by an XML stanza or some other XML event, and is --- sent through the internal event channel, just like client action events. - -data EnumeratorEvent = EnumeratorDone | - EnumeratorBeginStream (Maybe String) (Maybe String) (Maybe String) (Maybe String) (Maybe String) (Maybe String) | - EnumeratorEndStream | - EnumeratorFirstLevelElement (Either SomeException Element) | - 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 (Maybe [X509]) ([X509] -> 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 " ++ (show c) - show (CEAuthenticate u p r _) = "CEAuthenticate " ++ u ++ " " ++ p ++ " " ++ - (show r) - show (CEIQ s _ _ _) = "CEIQ" - show (CEMessage s _ _ _) = "CEMessage" - show (CEPresence s _ _ _) = "CEPresence" - - show (CEAction _ _) = "CEAction" - - -type StreamID = String - -data ConnectionState = Disconnected | Connected ServerAddress Handle - -data TLSState = NoTLS | PreProceed | PreHandshake | PostHandshake TLSCtx - -data Challenge = Chal String deriving (Show) - -data Success = Succ String deriving (Show) - - -type StreamProperties = Float -type StreamFeatures = String - - -data ConnectResult = ConnectSuccess StreamProperties StreamFeatures (Maybe Resource) | - ConnectOpenStreamFailure | - ConnectSecureWithTLSFailure | - ConnectAuthenticateFailure - -data OpenStreamResult = OpenStreamSuccess StreamProperties StreamFeatures | - OpenStreamFailure - -data SecureWithTLSResult = SecureWithTLSSuccess StreamProperties StreamFeatures | SecureWithTLSFailure - -data AuthenticateResult = AuthenticateSuccess StreamProperties StreamFeatures Resource | AuthenticateFailure - --- Address is a data type that has to be constructed in this module using either --- address or stringToAddress. - -data Address = Address { localpart :: Maybe Localpart - , domainpart :: Domainpart - , resourcepart :: Maybe Resourcepart } - deriving (Eq) - -instance Show Address where - show (Address { localpart = n, domainpart = s, resourcepart = r }) - | n == Nothing && r == Nothing = s - | r == Nothing = let Just n' = n in n' ++ "@" ++ s - | n == Nothing = let Just r' = r in s ++ "/" ++ r' - | otherwise = let Just n' = n; Just r' = r - in n' ++ "@" ++ s ++ "/" ++ r' - -type Localpart = String -type Domainpart = String -type Resourcepart = String - -data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq) - -type Timeout = Int - -data StreamError = StreamError - - --- ============================================================================= --- XML TYPES --- ============================================================================= - - -newtype IDGenerator = IDGenerator (IORef [String]) - - - - ---- other stuff - -data Version = Version { majorVersion :: Integer - , minorVersion :: Integer } deriving (Eq) - - --- Version numbers are displayed as ".". - -instance Show Version where - show (Version major minor) = (show major) ++ "." ++ (show minor) - - --- If the major version numbers are not equal, compare them. Otherwise, compare --- the minor version numbers. - -instance Ord Version where - compare (Version amajor aminor) (Version bmajor bminor) - | amajor /= bmajor = compare amajor bmajor - | otherwise = compare aminor bminor - - -data LangTag = LangTag { primaryTag :: String - , subtags :: [String] } - - --- Displays the language tag in the form of "en-US". - -instance Show LangTag where - show (LangTag p []) = p - show (LangTag p s) = p ++ "-" ++ (concat $ intersperse "-" s) - - --- Two language tags are considered equal of they contain the same tags (case-insensitive). - -instance Eq LangTag where - (LangTag ap as) == (LangTag bp bs) - | length as == length bs && map toLower ap == map toLower bp = all (\ (a, b) -> map toLower a == map toLower b) $ zip as bs - | otherwise = False diff --git a/Network/XMPP/Utilities.hs b/Network/XMPP/Utilities.hs deleted file mode 100644 --- a/Network/XMPP/Utilities.hs +++ /dev/null @@ -1,62 +0,0 @@ --- Copyright © 2010-2011 Jon Kristensen. See the LICENSE file in the Pontarius --- XMPP distribution for more details. - --- This module currently converts XML elements to strings. - --- TODO: Use -fno-cse? http://cvs.haskell.org/Hugs/pages/libraries/base/System-IO-Unsafe.html --- TODO: Remove elementsToString? - -{-# OPTIONS_HADDOCK hide #-} - -{-# LANGUAGE OverloadedStrings #-} - -module Network.XMPP.Utilities ( elementToString - , elementsToString ) where - -import Prelude hiding (concat) - -import Data.ByteString (ByteString, concat) -import Data.ByteString.Char8 (unpack) - -import Data.Enumerator (($$), Stream (Chunks), Enumerator, Step (Continue), joinI, run_, returnI) -import Data.Enumerator.List (consume) - -import Data.XML.Types (Document (..), Element (..), Event (..), Name (..), Prologue (..)) - -import Text.XML.Enumerator.Render (renderBytes) -import Text.XML.Enumerator.Document (toEvents) - -import System.IO.Unsafe (unsafePerformIO) - - --- Converts the Element objects to a document, converts it into Events, strips --- the DocumentBegin event, generates a ByteString, and converts it into a --- String, aggregates the results and returns a string. - -elementsToString :: [Element] -> String - -elementsToString [] = "" -elementsToString (e:es) = (elementToString (Just e)) ++ (elementsToString es) - - --- Converts the Element object to a document, converts it into Events, strips --- the DocumentBegin event, generates a ByteString, and converts it into a --- String. - -{-# NOINLINE elementToString #-} - -elementToString :: Maybe Element -> String - -elementToString Nothing = "" -elementToString (Just elem) = unpack $ concat $ unsafePerformIO $ do - r <- run_ $ events $$ (joinI $ renderBytes $$ consume) - return r - where - - -- Enumerator that "produces" the events to convert to the document - events :: Enumerator Event IO [ByteString] - events (Continue more) = more $ Chunks (tail $ toEvents $ dummyDoc elem) - events step = returnI step - - dummyDoc :: Element -> Document - dummyDoc e = Document (Prologue [] Nothing []) elem [] diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,22 +0,0 @@ -Pontarius XMPP 0.1 aims to implement the client capabilities of RFC 6120 ("XMPP -Core"). We have just released 0.1 Alpha 7, which may be the last version that is -not feature-complete. - -The current version of Pontarius XMPP is broken; the recent rewriting of some -modules broke the Session module. Fixing the Session module is one of the goals -for the next release. Other goals include working on the last missing features, -and improving the documentation and the API. - -We will soon move the project into beta. - -Please note that we are not recommending anyone to use Pontarius XMPP at this -time as it’s still in an experimental stage and will have its API and data types -modified. However, if you are interested to use Pontarius XMPP anyway, feel free -to contact the Pontarius project and we will try to help you get started. Please -see http://www.pontarius.org/ for documentation and more information. - -The next version is scheduled to be released on the 17th of August. - -Look at the Pontarius web site and the Pontarius -XMPP Hackage page for more -information. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,2 @@ import Distribution.Simple - main = defaultMain diff --git a/nohup.out b/nohup.out deleted file mode 100644 --- a/nohup.out +++ /dev/null @@ -1,942 +0,0 @@ -Using default Yi configuration -Now updating system metadata ... -***server start -Bind 127.0.0.1:26411 -Error reading cabal file "/home/Jon/.leksah-0.10/packageSources/blaze-builder-enumerator-0.2.0.2/blaze-builder-enumerator.cabal" "/home/Jon/.leksah-0.10/packageSources/blaze-builder-enumerator-0.2.0.2/blaze-builder-enumerator.cabal" (line 41, column 1): -unexpected end of input -expecting cabal minimal -update_toolbar 0.0 -update_toolbar 0.1 ---2011-07-12 14:23:11-- http://www.leksah.org/metadata-0.10/pontarius-xmpp-0.0.6.0.lkshm -Resolving www.leksah.org... 87.230.23.84 -Connecting to www.leksah.org|87.230.23.84|:80... connected. -HTTP request sent, awaiting response... 404 Not Found -2011-07-12 14:23:12 ERROR 404: Not Found. - -update_toolbar 0.2 ---2011-07-12 14:23:18-- http://www.leksah.org/metadata-0.10/enumerator-0.4.11.lkshm -Resolving www.leksah.org... 87.230.23.84 -Connecting to www.leksah.org|87.230.23.84|:80... connected. -HTTP request sent, awaiting response... 404 Not Found -2011-07-12 14:23:18 ERROR 404: Not Found. - -update_toolbar 0.3 ---2011-07-12 14:23:24-- http://www.leksah.org/metadata-0.10/uuid-1.2.2.lkshm -Resolving www.leksah.org... 87.230.23.84 -Connecting to www.leksah.org|87.230.23.84|:80... connected. -HTTP request sent, awaiting response... 404 Not Found -2011-07-12 14:23:24 ERROR 404: Not Found. - -Creating interfaces... -Checking module Network.XMPP.Utilities... -Creating interface... -haddock coverage for ./Network/XMPP/Utilities.hs: 1/3 33% -Checking module Network.XMPP.Types... -Creating interface... -haddock coverage for ./Network/XMPP/Types.hs: 18/45 40% -Checking module Network.XMPP.TLS... -Creating interface... -haddock coverage for ./Network/XMPP/TLS.hs: 1/3 33% -Checking module Network.XMPP.SASL... -Creating interface... -haddock coverage for ./Network/XMPP/SASL.hs: 0/2 0% -Checking module Network.XMPP.Address... -Creating interface... -haddock coverage for ./Network/XMPP/Address.hs: 5/5 100% -Checking module Network.XMPP.Stanza... -Creating interface... -haddock coverage for ./Network/XMPP/Stanza.hs: 11/11 100% -Checking module Network.XMPP.Stream... -Creating interface... -haddock coverage for ./Network/XMPP/Stream.hs: 1/10 10% -Checking module Network.XMPP.Session... -Creating interface... -haddock coverage for ./Network/XMPP/Session.hs: 5/19 26% -Checking module Network.XMPP... -Creating interface... -haddock coverage for ./Network/XMPP.hs: 24/47 51% -Attaching instances... -Building cross-linking environment... -Renaming interfaces... -Warning: Network.XMPP.Utilities: could not find link destinations for: - Data.Maybe.Maybe Data.XML.Types.Element GHC.Base.String -Warning: Network.XMPP.Types: could not find link destinations for: - GHC.Base.String GHC.Classes.Eq GHC.Show.Show Data.Maybe.Maybe Data.XML.Types.Element GHC.Integer.Type.Integer GHC.Exception.SomeException Network.TLS.Core.TLSCtx GHC.IO.Handle.Types.Handle Network.Socket.HostName Control.Monad.Trans.State.Lazy.StateT GHC.Bool.Bool Network.XMPP.Types.StreamProperties Network.XMPP.Types.StreamFeatures Network.Socket.Internal.PortNumber Control.Monad.Trans.Error.Error GHC.Types.Int GHC.IORef.IORef -Warning: Network.XMPP.TLS: could not find link destinations for: - Network.TLS.Core.TLSParams GHC.IO.Handle.Types.Handle GHC.Base.String GHC.Types.IO Data.Maybe.Maybe Network.TLS.Core.TLSCtx -Warning: Network.XMPP.SASL: could not find link destinations for: - GHC.Base.String Data.Either.Either Network.XMPP.SASL.Challenge1Error -Warning: Network.XMPP.Address: could not find link destinations for: - GHC.Base.String Data.Maybe.Maybe GHC.Bool.Bool -Warning: Network.XMPP.Stanza: could not find link destinations for: - Data.Maybe.Maybe Data.XML.Types.Element GHC.Base.String GHC.Types.IO -Warning: Network.XMPP.Stream: could not find link destinations for: - GHC.Bool.Bool Control.Concurrent.Chan.Chan Data.Either.Either GHC.IO.Handle.Types.Handle Network.TLS.Core.TLSCtx GHC.Types.IO Data.Enumerator.Iteratee Data.XML.Types.Event Data.Maybe.Maybe GHC.Base.String Data.XML.Types.Element -Warning: Network.XMPP.Session: could not find link destinations for: - Control.Monad.IO.Class.MonadIO Data.Maybe.Maybe Control.Monad.Trans.State.Lazy.StateT GHC.Bool.Bool Network.XMPP.Types.StreamProperties Network.XMPP.Types.StreamFeatures GHC.Base.String -Warning: Network.XMPP: could not find link destinations for: - Data.Maybe.Maybe GHC.Classes.Eq GHC.Show.Show GHC.Base.String GHC.Bool.Bool Data.Either.Either Network.XMPP.SASL.Challenge1Error Control.Monad.IO.Class.MonadIO Control.Monad.Trans.State.Lazy.StateT Network.XMPP.Types.StreamProperties Network.XMPP.Types.StreamFeatures GHC.Integer.Type.Integer Data.XML.Types.Element -9 -Creating interfaces... -Checking module Data.Enumerator.Util... -Creating interface... -haddock coverage for hs/Data/Enumerator/Util.hs: 0/7 0% -Checking module Data.Enumerator... -Checking module Data.Enumerator.List... -Checking module Data.Enumerator... -Creating interface... -haddock coverage for hs/Data/Enumerator.hs: 72/73 99% -Checking module Data.Enumerator.List... -Creating interface... -haddock coverage for hs/Data/Enumerator/List.hs: 42/42 100% -Checking module Data.Enumerator.Binary... -Creating interface... -haddock coverage for hs/Data/Enumerator/Binary.hs: 47/47 100% -Checking module Data.Enumerator.Text... -Creating interface... -haddock coverage for hs/Data/Enumerator/Text.hs: 49/57 86% -Checking module Data.Enumerator.IO... -Creating interface... -haddock coverage for hs/Data/Enumerator/IO.hs: 4/4 100% -Attaching instances... -Building cross-linking environment... -Renaming interfaces... -Warning: Data.Enumerator.Util: could not find link destinations for: - GHC.Types.Int GHC.Base.String GHC.Types.Char GHC.Word.Word8 GHC.Bool.Bool Data.Text.Internal.Text Data.Text.Lazy.Internal.Text -Warning: Data.Enumerator: could not find link destinations for: - GHC.Base.Monad GHC.Base.Functor Data.Typeable.Typeable1 Control.Applicative.Applicative GHC.Classes.Eq GHC.Show.Show Data.Monoid.Monoid Control.Monad.Trans.Class.MonadTrans Data.Typeable.Typeable Control.Monad.IO.Class.MonadIO GHC.Exception.SomeException Data.Either.Either GHC.Exception.Exception GHC.Bool.Bool GHC.Types.IO GHC.Integer.Type.Integer Data.Maybe.Maybe -Warning: Data.Enumerator.List: could not find link destinations for: - GHC.Base.Monad GHC.Integer.Type.Integer Data.Maybe.Maybe GHC.Bool.Bool GHC.Classes.Ord -Warning: Data.Enumerator.Binary: could not find link destinations for: - Control.Monad.IO.Class.MonadIO GHC.Integer.Type.Integer GHC.IO.Handle.Types.Handle Data.ByteString.Internal.ByteString Data.Maybe.Maybe GHC.IO.FilePath GHC.Types.IO GHC.Base.Monad GHC.Word.Word8 GHC.Bool.Bool Data.ByteString.Lazy.Internal.ByteString -Warning: Data.Enumerator.Text: could not find link destinations for: - Control.Monad.IO.Class.MonadIO GHC.IO.Handle.Types.Handle Data.Text.Internal.Text GHC.IO.FilePath GHC.Types.IO GHC.Base.Monad GHC.Types.Char GHC.Integer.Type.Integer Data.Maybe.Maybe GHC.Bool.Bool Data.Text.Lazy.Internal.Text GHC.Show.Show Data.ByteString.Internal.ByteString -Warning: Data.Enumerator.IO: could not find link destinations for: - Control.Monad.IO.Class.MonadIO GHC.Integer.Type.Integer GHC.IO.Handle.Types.Handle Data.ByteString.Internal.ByteString GHC.IO.FilePath GHC.Types.IO -6 -Creating interfaces... -Checking module Data.UUID.Builder... -Creating interface... -Warning: Data.UUID.Builder: Instances of type and data families are not yet supported. Instances of the following families will be filtered out: - ByteSink -haddock coverage for ./Data/UUID/Builder.hs: 2/7 29% -Checking module Data.UUID.Internal... -Creating interface... -Warning: Data.UUID.Internal: Instances of type and data families are not yet supported. Instances of the following families will be filtered out: - ByteSink -haddock coverage for ./Data/UUID/Internal.hs: 12/12 100% -Checking module Data.UUID.Named... -Creating interface... -haddock coverage for ./Data/UUID/Named.hs: 6/6 100% -Checking module Data.UUID.V5... -Creating interface... -haddock coverage for ./Data/UUID/V5.hs: 6/6 100% -Checking module Data.UUID.V3... -Creating interface... -haddock coverage for ./Data/UUID/V3.hs: 6/6 100% -Checking module Data.UUID.V1... -Creating interface... -Warning: Data.UUID.V1: Instances of type and data families are not yet supported. Instances of the following families will be filtered out: - ByteSink -haddock coverage for ./Data/UUID/V1.hs: 2/2 100% -Checking module Data.UUID... -Creating interface... -haddock coverage for ./Data/UUID.hs: 10/10 100% -Attaching instances... -Building cross-linking environment... -Renaming interfaces... -Warning: Data.UUID.Builder: could not find link destinations for: - GHC.Types.Int GHC.Word.Word8 GHC.Word.Word16 GHC.Word.Word32 Data.UUID.Internal.ThreeByte Data.UUID.V1.MACSource -Warning: Data.UUID.Internal: could not find link destinations for: - GHC.Word.Word32 GHC.Classes.Eq Data.Data.Data GHC.Classes.Ord GHC.Read.Read GHC.Show.Show Data.Typeable.Typeable Foreign.Storable.Storable Data.Binary.Binary System.Random.Random GHC.Bool.Bool Data.ByteString.Lazy.Internal.ByteString Data.Maybe.Maybe GHC.Base.String GHC.Word.Word8 -Warning: Data.UUID.Named: could not find link destinations for: - GHC.Word.Word8 GHC.Word.Word32 -Warning: Data.UUID.V5: could not find link destinations for: - GHC.Word.Word8 -Warning: Data.UUID.V3: could not find link destinations for: - GHC.Word.Word8 -Warnupdate_toolbar 0.4 ---2011-07-12 14:23:30-- http://www.leksah.org/metadata-0.10/maccatcher-2.1.1.lkshm -Resolving www.leksah.org... 87.230.23.84 -Connecting to www.leksah.org|87.230.23.84|:80... connected. -HTTP request sent, awaiting response... 404 Not Found -2011-07-12 14:23:30 ERROR 404: Not Found. - -update_toolbar 0.5 ---2011-07-12 14:23:35-- http://www.leksah.org/metadata-0.10/Crypto-4.2.3.lkshm -Resolving www.leksah.org... 87.230.23.84 -Connecting to www.leksah.org|87.230.23.84|:80... connected. -HTTP request sent, awaiting response... 404 Not Found -2011-07-12 14:23:35 ERROR 404: Not Found. - -update_toolbar 0.6 ---2011-07-12 14:23:41-- http://www.leksah.org/metadata-0.10/happstack-server-6.1.5.lkshm -Resolving www.leksah.org... 87.230.23.84 -Connecting to www.leksah.org|87.230.23.84|:80... connected. -HTTP request sent, awaiting response... 404 Not Found -2011-07-12 14:23:42 ERROR 404: Not Found. - -ing: Data.UUID.V1: could not find link destinations for: - GHC.Types.IO Data.Maybe.Maybe -Warning: Data.UUID: could not find link destinations for: - GHC.Classes.Eq Data.Data.Data GHC.Classes.Ord GHC.Read.Read GHC.Show.Show Data.Typeable.Typeable Foreign.Storable.Storable Data.Binary.Binary System.Random.Random GHC.Base.String Data.Maybe.Maybe Data.ByteString.Lazy.Internal.ByteString GHC.Word.Word32 GHC.Bool.Bool -7 -Creating interfaces... -Checking module Data.MAC... -Creating interface... -haddock coverage for ./Data/MAC.hs: 1/2 50% -Checking module System.Info.MAC.Fetch... -Creating interface... -haddock coverage for ./System/Info/MAC/Fetch.hs: 5/13 38% -Checking module System.Info.MAC... -Creating interface... -haddock coverage for ./System/Info/MAC.hs: 6/6 100% -Attaching instances... -Building cross-linking environment... -Renaming interfaces... -Warning: Data.MAC: could not find link destinations for: - GHC.Word.Word8 GHC.Enum.Bounded GHC.Classes.Eq GHC.Classes.Ord GHC.Read.Read GHC.Show.Show Foreign.Storable.Storable Data.Binary.Binary -Warning: System.Info.MAC.Fetch: could not find link destinations for: - GHC.Types.IO GHC.Base.String Text.Parsec.String.Parser Data.Maybe.Maybe GHC.Types.Char -Warning: System.Info.MAC: could not find link destinations for: - GHC.Types.IO Data.Maybe.Maybe GHC.Base.String -3 -Creating interfaces... -Checking module Data.Digest.MD5Aux... -Creating interface... -haddock coverage for ./Data/Digest/MD5Aux.hs: 0/10 0% -Checking module Codec.Encryption.DESAux... -Creating interface... -haddock coverage for ./Codec/Encryption/DESAux.hs: 0/3 0% -Checking module Codec.Encryption.BlowfishAux... -Creating interface... -haddock coverage for ./Codec/Encryption/BlowfishAux.hs: 0/4 0% -Checking module Data.Digest.SHA2... -Creating interface... -haddock coverage for ./Data/Digest/SHA2.hs: 6/14 43% -Checking module Codec.Utils... -Creating interface... -haddock coverage for ./Codec/Utils.hs: 11/12 92% -Checking module Data.Digest.MD5... -Creating interface... -haddock coverage for ./Data/Digest/MD5.hs: 3/3 100% -Checking module Data.Digest.SHA1... -Creating interface... -haddock coverage for ./Data/Digest/SHA1.hs: 1/5 20% -Checking module Data.Digest.SHA224... -Creating interface... -haddock coverage for ./Data/Digest/SHA224.hs: 3/3 100% -Checking module Data.Digest.SHA256... -Creating interface... -haddock coverage for ./Data/Digest/SHA256.hs: 3/3 100% -Checking module Data.Digest.SHA384... -Creating interface... -haddock coverage for ./Data/Digest/SHA384.hs: 3/3 100% -Checking module Data.Digest.SHA512... -Creating interface... -haddock coverage for ./Data/Digest/SHA512.hs: 3/3 100% -Checking module Data.HMAC... -Creating interface... -haddock coverage for ./Data/HMAC.hs: 7/7 100% -Checking module Codec.Encryption.AESAux... -Creating interface... -haddock coverage for ./Codec/Encryption/AESAux.hs: 1/7 14% -Checking module Codec.Text.Raw... -Creating interface... -haddock coverage for ./Codec/Text/Raw.hs: 1/3 33% -Checking module Codec.Encryption.Padding... -Creating interface... -haddock coverage for ./Codec/Encryption/Padding.hs: 6/6 100% -Checking module Codec.Encryption.Modes... -Creating interface... -haddock coverage for ./Codec/Encryption/Modes.hs: 4/4 100% -Checking module Codec.Encryption.Blowfish... -Creating interface... -haddock coverage for ./Codec/Encryption/Blowfish.hs: 4/4 100% -Checking module Codec.Encryption.TEA... -Creating interface... -haddock coverage for ./Codec/Encryption/TEA.hs: 1/4 25% -Checking module Codec.Encryption.DES... -Creating interface... -haddock coverage for ./Codec/Encryption/DES.hs: 4/4 100% -Checking module Codec.Encryption.RSA.NumberTheory... -Creating interface... -haddock coverage for ./Codec/Encryption/RSA/NumberTheory.hs: 0/14 0% -Checking module Codec.Encryption.RSA.MGF... -Creating interface... -haddock coverage for ./Codec/Encryption/RSA/MGF.hs: 3/3 100% -Checking module Codec.Encryption.RSA.EMEOAEP... -Creating interface... -haddock coverage for ./Codec/Encryption/RSA/EMEOAEP.hs: 4/4 100% -Checking module Codec.Encryption.RSA... -Creating interface... -haddock coverage for ./Codec/Encryption/RSA.hs: 4/4 100% -Checking module Codec.Binary.BubbleBabble... -Creating interface... -haddock coverage for ./Codec/Binary/BubbleBabble.hs: 1/2 50% -Checking module Data.LargeWord... -Creating interface... -haddock coverage for ./Data/LargeWord.hs: 1/8 12% -Checking module Codec.Encryption.AES... -Creating interface... -haddock coverage for ./Codec/Encryption/AES.hs: 4/5 80% -Attaching instances... -Building cross-linking environment... -Renaming interfaces... -Warning: Data.Digest.MD5Aux: could not find link destinations for: - GHC.Base.String GHC.Integer.Type.Integer GHC.Word.Word32 GHC.Types.Int GHC.Bool.Bool GHC.Classes.Eq GHC.Num.Num GHC.Show.Show GHC.Word.Word64 -Warning: Codec.Encryption.DESAux: could not find link destinations for: - Codec.Encryption.DESAux.Message Codec.Encryption.DESAux.Key Codec.Encryption.DESAux.Enc -Warning: Codec.Encryption.BlowfishAux: could not find link destinations for: - GHC.Types.Char Codec.Encryption.BlowfishAux.BF GHC.Word.Word32 -Warning: Data.Digest.SHA2: could not find link destinations for: - Data.Bits.Bits GHC.Real.Integral GHC.Base.String Data.Digest.SHA2.Hash8 GHC.Word.Word32 GHC.Word.Word64 GHC.Classes.Eq GHC.Classes.Ord GHC.Show.Show Data.Digest.SHA2.Hash GHC.Word.Word8 -Warning: Codec.Utils: could not find link destinations for: - GHC.Word.Word8 GHC.Types.Int GHC.Real.Integral Data.Bits.Bits -Warning: Data.Digest.SHA1: could not find link destinations for: - GHC.Word.Word32 GHC.Classes.Eq GHC.Show.Show GHC.Word.Word8 GHC.Integer.Type.Integer -Warning: Data.HMAC: could not find link destinations for: - GHC.Types.Int -Warning: Codec.Text.Raw: could not find link destinations for: - Codec.Text.Raw.OctetsPerLine Text.PrettyPrint.HughesPJ.Doc GHC.Base.String -Warning: Codec.Encryption.Padding: could not find link destinations for: - GHC.Real.Integral Data.Bits.Bits -Warning: Codec.Encryption.Modes: could not find link destinations for: - Data.Bits.Bits -Warning: Codec.Encryption.Blowfish: could not find link destinations for: - GHC.Real.Integral GHC.Word.Word64 -Warning: Codec.Encryption.TEA: could not find link destinations for: - GHC.Word.Word32 GHC.Word.Word64 -Warning: Codec.Encryption.DES: could not find link destinations for: - GHC.Word.Word64 -Warning: Codec.Encryption.RSA.NumberTheory: could not find link destinations for: - GHC.Integer.Type.Integer GHC.Bool.Bool GHC.Types.Int GHC.Types.IO GHC.Base.String -Warning: Codec.Encryption.RSA.MGF: could not find link destinations for: - GHC.Types.Int -Warning: Codec.Encryption.RSA.EMEOAEP: could not find link destinations for: - GHC.Types.Int -Warning: Codec.Binary.BubbleBabble: could not find link destinations for: - GHC.Base.String -Warning: Data.LargeWord: could not find link destinations for: - Codec.Encryption.AES.AESKeyIndirection GHC.Classes.Ord Data.Bits.Bits GHC.Enum.Bounded GHC.Real.Integral Data.LargeWord.LargeWord GHC.Enum.Enum GHC.Classes.Eq GHC.Num.Num GHC.Real.Real GHC.Show.Show GHC.Word.Word32 GHC.Word.Word64 -Warning: Codec.Encryption.AES: could not find link destinations for: - Codec.Encryption.AES.AESKeyIndirection -26 -Creating interfaces... -Checking module Paths_happstack_server... -Creating interface... -haddock coverage for dist/build/autogen/Paths_happstack_server.hs: 0/7 0% -Checking module Happstack.Server.SURI.ParseURI... -Creating interface... -haddock coverage for src/Happstack/Server/SURI/ParseURI.hs: 0/2 0% -Checking module Happstack.Server.Internal.SocketTH... -Creating interface... -haddock coverage for src/Happstack/Server/Internal/SocketTH.hs: 0/2 0% -Checking module Happstack.Server.Internal.Socket... -Creating interface... -haddock coverage for src/Happstack/Server/Internal/Socket.hs: 1/2 50% -Checking module Happstack.Server.Internal.RFC822Headers... -Creating interface... -haddock coverage for src/Happstack/Server/Internal/RFC822Headers.hs: 9/21 43% -Checking module Happstack.Server.Internal.LazyLiner... -Creating interface... -Warning: Couldn't find .haddock for exported Happstack.Server.Internal.LazyLiner.toChunks: bytestring-0.9.1.10:Data.ByteString.Lazy.toChunks -haddock coverage for src/Happstack/Server/Internal/LazyLiner.hs: 0/8 0% -Checking module Happstack.Server.Internal.Clock... -Creating interface... -haddock coverage for src/Happstack/Server/Internal/Clock.hs: 0/5 0% -Checking module Happstack.Server.HTTPClient.Stream... -Creating interface... -haddock coverage for src/Happstack/Server/HTTPClient/Stream.hs: 7/11 64% -Checking module Happstack.Server.HTTPClient.TCP... -Creating interface... -haddock coverage for src/Happstack/Server/HTTPClient/TCP.hs: 7/7 100% -Checking module Happstack.Server.HTTPClient.HTTP... -Creating interface... -haddock coverage for src/Happstack/Server/HTTPClient/HTTP.hs: 20/29 69% -Checking module Happstack.Server.SURI... -Creating interface... -haddock coverage for src/Happstack/Server/SURI.hs: 12/16 75% -Checking module Happstack.Server.Internal.TimeoutManager... -Creating interface... -haddock coverage for src/Happstack/Server/Internal/TimeoutManager.hs: 0/9 0% -Checking module Happstack.Server.Internal.TimeoutSocket... -Creating interface... -haddock coverage for src/Happstack/Server/Internal/TimeoutSocket.hs: 1/5 20% -Checking module Happstack.Server.Internal.Cookie... -Creating interface... -haddock coverage for src/Happstack/Server/Internal/Cookie.hs: 8/12 67% -Checking module Happstack.Server.Internal.Types... -Creating interface... -haddock coverage for src/Happstack/Server/Internal/Types.hs: 41/42 98% -Checking module Happstack.Server.Types... -Creating interface... -haddock coverage for src/Happstack/Server/Types.hs: 41/42 98% -Checking module Happstack.Server.Internal.Monads... -Creating interface... -haddock coverage for src/Happstack/Server/Internal/Monads.hs: 27/33 82% -Checking module Happstack.Server.Response... -Creating interface... -haddock coverage for src/Happstack/Server/Response.hs: 23/23 100% -Checking module Happstack.Server.Validation... -Creating interface... -haddock coverage for src/Happstack/Server/Validation.hs: 8/8 100% -Checking module Happstack.Server.Internal.Multipart... -Creating interface... -haddock coverage for src/Happstack/Server/Internal/Multipart.hs: 6/31 19% -Checking module Happstack.Server.Internal.MessageWrap... -Creating interface... -haddock coverage for src/Happstack/Server/Internal/MessageWrap.hs: 6/11 55% -Checking module Happstack.Server.Internal.Handler... -Creating interface... -haddock coverage for src/Happstack/Server/Internal/Handler.hs: 2/4 50% -Checking module Happstack.Server.Internal.Listen... -Creating interface... -haddock coverage for src/Happstack/Server/Internal/Listen.hs: 2/5 40% -Checking module Happstack.Server.Internal.LowLevel... -Creating interface... -haddock coverage for src/Happstack/Server/Internal/LowLevel.hs: 8/9 89% -Checking module Happstack.Server.Client... -Creating interface... -haddock coverage for src/Happstack/Server/Client.hs: 2/2 100% -Checking module Happstack.Server.Cookie... -Creating interface... -haddock coverage for src/Happstack/Server/Cookie.hs: 7/7 100% -Checking module Happstack.Server.RqData... -Creating interface... -haddock coverage for src/Happstack/Server/RqData.hs: 46/46 100% -Checking module Happstack.Server.Monads... -Creating interface... -haddock coverage for src/Happstack/Server/Monads.hs: 25/25 100% -Checking module Happstack.Server.Error... -Creating interface... -haddock coverage for src/Happstack/Server/Error.hs: 4/4 100% -Checking module Happstack.Server.FileServe.BuildingBlocks... -Creating interface... -haddock coverage for src/Happstack/Server/FileServe/BuildingBlocks.hs: 32/35 91% -Checking module Happstack.Server.FileServe... -Creating interface... -haddock coverage for src/Happstack/Server/FileServe.hs: 14/14 100% -Checking module Happstack.Server.Proxy... -Creating interface... -haddock coverage for src/Happstack/Server/Proxy.hs: 4/6 67% -Checking module Happstack.Server.Routing... -Creating interface... -haddock coverage for src/Happstack/Server/Routing.hs: 21/21 100% -Checking module Happstack.Server.Auth... -Creating interface... -haddock coverage for src/Happstack/Server/Auth.hs: 2/2 100% -Checking module Happstack.Server.SimpleHTTP... -Creating interface... -doc comment parse failed: Bind to ip and port and return the socket for use with 'simpleHTTPWithSocket'. - > - > import Happstack.Server - > - > main = do let conf = nullConf - > addr = "127.0.0.1" - > s <- bindIPv4 addr (port conf) - > simpleHTTPWithSocket s conf $ ok $ toResponse $ - > "now listening on ip addr " ++ addr ++ - > " and port " ++ show (port conf) -haddock coverage for src/Happstack/Server/SimpleHTTP.hs: 29/30 97% -Checking module Happstack.Server.Internal.Compression... -Creating interface... -haddock coverage for src/Happstack/Server/Internal/Compression.hs: 6/6 100% -Checking module Happstack.Server.Compression... -Creating interface... -haddock coverage for src/Happstack/Server/Compression.hs: 2/2 100% -Checking module Happstack.Server.XSLT... -Creating interface... -haddock coverage for src/Happstack/Server/XSLT.hs: 8/14 57% -Checking module Happstack.Server... -Creating interface... -haddock coverage for src/Happstack/Server.hs: 27/27 100% -Attaching instances... -Building cross-linking environment... -Renaming interfaces... -Warning: Paths_happstack_server: could not find link destinations for: - Data.Version.Version GHC.Types.IO GHC.IO.FilePath -Warning: Happstack.Server.SURI.ParseURI: could not find link destinations for: - Data.ByteString.Internal.ByteString Network.URI.URI -Warning: Happstack.Server.Internal.SocketTH: could not find link destinations for: - GHC.Bool.Bool -Warning: Happstack.Server.Internal.Socket: could not find link destinations for: - Network.Socket.Socket GHC.Types.IO Network.Socket.HostName Network.Socket.Internal.PortNumber -Warning: Happstack.Server.Internal.LazyLiner: could not find link destinations for: - GHC.IO.Handle.Types.Handle GHC.Types.IO Data.ByteString.Internal.ByteString GHC.Types.Int Data.ByteString.Lazy.Internal.ByteString -Warning: Happstack.Server.Internal.Clock: could not find link destinations for: - GHC.Types.IO Data.ByteString.Internal.ByteString Data.Time.Clock.POSIX.POSIXTime Data.Time.Clock.UTC.UTCTime GHC.Base.String -Warning: Happstack.Server.HTTPClient.Stream: could not find link destinations for: - GHC.Types.IO GHC.Base.String GHC.Types.Int Network.Socket.Socket GHC.Classes.Eq GHC.Show.Show Data.Either.Either GHC.Exception.SomeException -Warning: Happstack.Server.HTTPClient.TCP: could not find link destinations for: - Network.Socket.Socket Network.Socket.Internal.SockAddr GHC.Base.String GHC.Classes.Eq GHC.IORef.IORef GHC.Types.IO GHC.Types.Int GHC.Bool.Bool -Warning: Happstack.Server.HTTPClient.HTTP: could not find link destinations for: - GHC.Base.String Network.URI.URI GHC.Show.Show Happstack.Server.HTTPClient.HTTP.ResponseCode GHC.Classes.Eq GHC.Types.IO Data.Maybe.Maybe -Warning: Happstack.Server.SURI: could not find link destinations for: - GHC.Base.String GHC.Bool.Bool Network.URI.URI GHC.Classes.Eq Data.Data.Data GHC.Classes.Ord GHC.Read.Read GHC.Show.Show Data.Typeable.Typeable Data.Maybe.Maybe -Warning: Happstack.Server.Internal.TimeoutManager: could not find link destinations for: - GHC.Types.Int GHC.Types.IO -Warning: Happstack.Server.Internal.TimeoutSocket: could not find link destinations for: - Network.Socket.Socket Data.ByteString.Lazy.Internal.ByteString GHC.Types.IO GHC.IO.FilePath Network.Socket.SendFile.Offset Network.Socket.SendFile.ByteCount Network.Socket.SendFile.Iter.Iter -Warning: Happstack.Server.Internal.Cookie: could not find link destinations for: - GHC.Base.String GHC.Bool.Bool GHC.Classes.Eq Data.Data.Data GHC.Read.Read GHC.Show.Show Data.Typeable.Typeable Control.Monad.Reader.Class.MonadReader Happstack.Util.Common.Seconds Data.Time.Clock.UTC.UTCTime GHC.Classes.Ord GHC.Types.IO Data.Maybe.Maybe GHC.Base.Monad Dupdate_toolbar 0.7 ---2011-07-12 14:24:23-- http://www.leksah.org/metadata-0.10/idna2008-0.0.1.0.lkshm -Resolving www.leksah.org... 87.230.23.84 -Connecting to www.leksah.org|87.230.23.84|:80... connected. -HTTP request sent, awaiting response... 404 Not Found -2011-07-12 14:24:23 ERROR 404: Not Found. - -ata.ByteString.Internal.ByteString Data.Either.Either Text.Parsec.String.GenParser GHC.Types.Char -Warning: Happstack.Server.Internal.Types: could not find link destinations for: - GHC.Base.String GHC.MVar.MVar GHC.Show.Show Data.Typeable.Typeable Happstack.Server.Internal.Types.HasHeaders GHC.Types.Int Data.ByteString.Lazy.Internal.ByteString Data.Maybe.Maybe GHC.Types.IO GHC.IO.FilePath GHC.Integer.Type.Integer Control.Monad.Trans.Error.Error GHC.Base.Monad GHC.Read.Read Data.Either.Either Control.Monad.Reader.Class.MonadReader Data.ByteString.Internal.ByteString Control.Monad.IO.Class.MonadIO GHC.Bool.Bool Data.Time.Format.FormatTime GHC.Classes.Eq GHC.Enum.Enum GHC.Classes.Ord Data.Data.Data Data.Map.Map -Warning: Happstack.Server.Types: could not find link destinations for: - GHC.Base.String GHC.MVar.MVar GHC.Show.Show Data.Typeable.Typeable Happstack.Server.Internal.Types.HasHeaders GHC.Types.Int Data.ByteString.Lazy.Internal.ByteString Data.Maybe.Maybe GHC.Types.IO GHC.IO.FilePath GHC.Integer.Type.Integer Control.Monad.Trans.Error.Error GHC.Base.Monad GHC.Read.Read Data.Either.Either Control.Monad.Reader.Class.MonadReader Data.ByteString.Internal.ByteString Control.Monad.IO.Class.MonadIO GHC.Bool.Bool Data.Time.Format.FormatTime GHC.Classes.Eq GHC.Enum.Enum GHC.Classes.Ord Data.Data.Data Data.Map.Map -Warning: Happstack.Server.Internal.Monads: could not find link destinations for: - GHC.Types.IO Control.Monad.Trans.Reader.ReaderT Control.Monad.Trans.Class.MonadTrans GHC.Base.Monad Control.Monad.State.Class.MonadState Control.Monad.Reader.Class.MonadReader Control.Monad.Error.Class.MonadError Control.Monad.Writer.Class.MonadWriter GHC.Base.Functor Control.Monad.MonadPlus Control.Applicative.Applicative Control.Monad.IO.Class.MonadIO Control.Applicative.Alternative Data.Monoid.Monoid Control.Monad.Trans.Error.Error Control.Monad.Trans.Error.ErrorT GHC.Classes.Eq GHC.Show.Show Data.Monoid.Dual Data.Monoid.Endo Control.Monad.Trans.Writer.Lazy.WriterT Control.Monad.Maybe.MaybeT Data.Maybe.Maybe Data.Either.Either GHC.Base.String -Warning: Happstack.Server.Response: could not find link destinations for: - Data.ByteString.Internal.ByteString Data.ByteString.Lazy.Internal.ByteString GHC.Integer.Type.Integer GHC.Base.String Data.Text.Internal.Text Data.Text.Lazy.Internal.Text Text.Blaze.Internal.Html Text.Html.Html Text.XHtml.Internals.Html Data.Maybe.Maybe GHC.Base.Functor GHC.Types.Int System.Time.CalendarTime -Warning: Happstack.Server.Validation: could not find link destinations for: - GHC.Types.IO GHC.Base.Monad Control.Monad.IO.Class.MonadIO GHC.IO.FilePath GHC.Base.String Data.Maybe.Maybe Data.ByteString.Internal.ByteString GHC.Bool.Bool -Warning: Happstack.Server.Internal.Multipart: could not find link destinations for: - Data.ByteString.Lazy.Internal.ByteString GHC.Bool.Bool GHC.Classes.Eq GHC.Classes.Ord GHC.Read.Read GHC.Show.Show GHC.Base.String GHC.Types.IO Data.Maybe.Maybe Happstack.Server.Internal.RFC822Headers.Header GHC.IO.FilePath GHC.Int.Int64 GHC.IO.Handle.Types.Handle -Warning: Happstack.Server.Internal.MessageWrap: could not find link destinations for: - GHC.Base.String GHC.Int.Int64 GHC.IO.FilePath Control.Monad.IO.Class.MonadIO Data.Maybe.Maybe Data.ByteString.Lazy.Internal.ByteString GHC.Types.IO GHC.Read.Read GHC.Types.Char GHC.Types.Double GHC.Types.Float GHC.Types.Int -Warning: Happstack.Server.Internal.Handler: could not find link destinations for: - Network.Socket.Socket GHC.Types.IO Data.ByteString.Lazy.Internal.ByteString Data.Either.Either GHC.Base.String GHC.IO.Handle.Types.Handle -Warning: Happstack.Server.Internal.Listen: could not find link destinations for: - GHC.Types.IO Network.Socket.Socket GHC.Types.Int GHC.Base.String -Warning: Happstack.Server.Client: could not find link destinations for: - GHC.Types.IO Data.Either.Either GHC.Base.String -Warning: Happstack.Server.Cookie: could not find link destinations for: - GHC.Base.String GHC.Bool.Bool GHC.Classes.Eq Data.Data.Data GHC.Read.Read GHC.Show.Show Data.Typeable.Typeable Control.Monad.Reader.Class.MonadReader Happstack.Util.Common.Seconds Data.Time.Clock.UTC.UTCTime GHC.Classes.Ord Control.Monad.IO.Class.MonadIO -Warning: Happstack.Server.RqData: could not find link destinations for: - GHC.Base.Functor GHC.Base.Monad GHC.Base.String Data.Text.Lazy.Internal.Text Data.ByteString.Lazy.Internal.ByteString GHC.Read.Read GHC.IO.FilePath Data.Either.Either Control.Monad.MonadPlus Control.Monad.IO.Class.MonadIO GHC.Int.Int64 Control.Applicative.Applicative Control.Applicative.Alternative Control.Monad.Reader.Class.MonadReader Data.Typeable.Typeable1 GHC.Classes.Eq Data.Data.Data GHC.Classes.Ord GHC.Show.Show Control.Monad.Trans.Error.Error Data.Monoid.Monoid Data.Maybe.Maybe -Warning: Happstack.Server.Monads: could not find link destinations for: - Control.Monad.Trans.Class.MonadTrans GHC.Base.Monad Control.Monad.State.Class.MonadState Control.Monad.Reader.Class.MonadReader Control.Monad.Error.Class.MonadError Control.Monad.Writer.Class.MonadWriter GHC.Base.Functor Control.Monad.MonadPlus Control.Applicative.Applicative Control.Monad.IO.Class.MonadIO Control.Applicative.Alternative Data.Monoid.Monoid GHC.Types.IO Control.Monad.Trans.Error.Error Control.Monad.Trans.Error.ErrorT Data.Maybe.Maybe Data.Either.Either GHC.Base.String Data.ByteString.Internal.ByteString -Warning: Happstack.Server.Error: could not find link destinations for: - GHC.Base.Monad Control.Monad.Trans.Error.ErrorT GHC.Base.String Control.Monad.Trans.Error.Error -Warning: Happstack.Server.FileServe.BuildingBlocks: could not find link destinations for: - Control.Monad.IO.Class.MonadIO Control.Monad.MonadPlus GHC.IO.FilePath GHC.Base.String GHC.Enum.Enum GHC.Classes.Eq Data.Data.Data GHC.Classes.Ord GHC.Read.Read GHC.Show.Show Data.Typeable.Typeable Data.Maybe.Maybe System.Time.CalendarTime GHC.Integer.Type.Integer Data.ByteString.Lazy.Internal.ByteString Data.ByteString.Internal.ByteString Data.Map.Map GHC.Base.Monad GHC.Types.IO GHC.Bool.Bool -Warning: Happstack.Server.FileServe: could not find link destinations for: - GHC.Enum.Enum GHC.Classes.Eq Data.Data.Data GHC.Classes.Ord GHC.Read.Read GHC.Show.Show Data.Typeable.Typeable Control.Monad.IO.Class.MonadIO Control.Monad.MonadPlus GHC.IO.FilePath GHC.Base.String Data.Map.Map GHC.Base.Monad -Warning: Happstack.Server.Proxy: could not find link destinations for: - Control.Monad.IO.Class.MonadIO Control.Monad.MonadPlus GHC.Base.String -Warning: Happstack.Server.Routing: could not find link destinations for: - Control.Monad.MonadPlus GHC.Base.Monad GHC.Bool.Bool GHC.Base.String GHC.IO.FilePath Data.Maybe.Maybe GHC.Types.Double GHC.Types.Float GHC.Types.Int GHC.Integer.Type.Integer -Warning: Happstack.Server.Auth: could not find link destinations for: - Control.Monad.MonadPlus GHC.Base.String Data.Map.Map -Warning: Happstack.Server.SimpleHTTP: could not find link destinations for: - GHC.Types.IO GHC.Base.Monad GHC.Base.Functor Network.Socket.Socket GHC.Base.String GHC.Types.Int Data.Either.Either -Warning: Happstack.Server.Internal.Compression: could not find link destinations for: - Control.Monad.MonadPlus GHC.Base.String Data.ByteString.Lazy.Internal.ByteString GHC.Bool.Bool Text.Parsec.String.GenParser GHC.Types.Char Data.Maybe.Maybe GHC.Types.Double -Warning: Happstack.Server.Compression: could not find link destinations for: - Control.Monad.MonadPlus GHC.Base.String -Warning: Happstack.Server.XSLT: could not find link destinations for: - GHC.IO.FilePath GHC.Types.IO GHC.Base.String Data.ByteString.Internal.ByteString Control.Monad.IO.Class.MonadIO Control.Monad.MonadPlus Data.ByteString.Lazy.Internal.ByteString GHC.Classes.Eq Data.Data.Data GHC.Classes.Ord GHC.Read.Read GHC.Show.Show Data.Typeable.Typeable Happstack.Data.Default.Default Data.Generics.SYB.WithClass.Context.Sat Data.Generics.SYB.WithClass.Basics.Data -39 -Creating interfaces... -Checking module Data.Text.IDNA2008... -Creating interface... -haddock coverage for ./Data/Text/IDNA2008.hs: 2/2 100% -Attaching instances... -Building cross-linking environment... -Rupdate_toolbar 0.8 ---2011-07-12 14:24:28-- http://www.leksah.org/metadata-0.10/stringprep-0.1.4.lkshm -Resolving www.leksah.org... 87.230.23.84 -Connecting to www.leksah.org|87.230.23.84|:80... connected. -HTTP request sent, awaiting response... 404 Not Found -2011-07-12 14:24:28 ERROR 404: Not Found. - -update_toolbar 0.9 ---2011-07-12 14:24:34-- http://www.leksah.org/metadata-0.10/stream-fusion-0.1.2.3.lkshm -Resolving www.leksah.org... 87.230.23.84 -Connecting to www.leksah.org|87.230.23.84|:80... connected. -HTTP request sent, awaiting response... 404 Not Found -2011-07-12 14:24:34 ERROR 404: Not Found. - -update_toolbar 1.0 ---2011-07-12 14:24:45-- http://www.leksah.org/metadata-0.10/ranges-0.2.3.lkshm -Resolving www.leksah.org... 87.230.23.84 -Connecting to www.leksah.org|87.230.23.84|:80... connected. -HTTP request sent, awaiting response... 404 Not Found -2011-07-12 14:24:45 ERROR 404: Not Found. - -Metadata collection has finished -Now loading metadata ... -Now updating workspace metadata ... -Finished ->>>Info Changed!!! True - -/home/Jon/tls-0.7.1/Tests.hs:32:0: - error: missing binary operator before token "(" -Can't extract module /home/Jon/.leksah-0.10/metadata/tls-0.7.1/Main.lkshe leksah-server: phase `C pre-processor' failed (exitcode = 1) - -/home/Jon/tls-0.7.1/Tests.hs:32:0: - error: missing binary operator before token "(" -Can't extract module /home/Jon/.leksah-0.10/metadata/tls-0.7.1/Main.lkshe leksah-server: phase `C pre-processor' failed (exitcode = 1) ->>>Info Changed!!! False ->>>Info Changed!!! False - -/home/Jon/tls-0.7.1/Tests.hs:32:0: - error: missing binary operator before token "(" -Can't extract module /home/Jon/.leksah-0.10/metadata/tls-0.7.1/Main.lkshe leksah-server: phase `C pre-processor' failed (exitcode = 1) ->>>Info Changed!!! False - -(leksah:21940): Gtk-WARNING **: Unknown tag `ErrorRef0' - -(leksah:21940): Gtk-WARNING **: Unknown tag `ErrorRef1' - -(leksah:21940): IBUS-WARNING **: org.freedesktop.IBus.InputContext.GetEngine: GDBus.Error:org.freedesktop.DBus.Error.Failed: Input context does not have engine. - -/home/Jon/tls-0.7.1/Tests.hs:32:0: - error: missing binary operator before token "(" -Can't extract module /home/Jon/.leksah-0.10/metadata/tls-0.7.1/Main.lkshe leksah-server: phase `C pre-processor' failed (exitcode = 1) ->>>Info Changed!!! False -Now saving session -***lost connection -***lost last connection - exiting -***lost last connection - waiting -ExitSuccess -enaming interfaces... -Warning: Data.Text.IDNA2008: could not find link destinations for: - GHC.Base.String Data.Maybe.Maybe -1 -Creating interfaces... -Checking module Text.StringPrep... -Creating interface... -haddock coverage for ./Text/StringPrep.hs: 0/17 0% -Checking module Text.NamePrep... -Creating interface... -haddock coverage for ./Text/NamePrep.hs: 0/2 0% -Attaching instances... -Building cross-linking environment... -Renaming interfaces... -Warning: Text.StringPrep: could not find link destinations for: - Text.StringPrep.Map GHC.Bool.Bool Text.StringPrep.Prohibited Data.Text.Internal.Text Data.Maybe.Maybe Data.Ranges.Range GHC.Types.Char -Warning: Text.NamePrep: could not find link destinations for: - GHC.Bool.Bool -2 -Creating interfaces... -Checking module Data.Stream... -Creating interface... -haddock coverage for ./Data/Stream.hs: 31/108 29% -Checking module Control.Monad.Stream... -Creating interface... -Warning: Couldn't find .haddock for exported Control.Monad.Stream.Functor: base:GHC.Base.Functor -Warning: Couldn't find .haddock for exported Control.Monad.Stream.Monad: base:GHC.Base.Monad -haddock coverage for ./Control/Monad/Stream.hs: 39/41 95% -Checking module Data.List.Stream... -Creating interface... -haddock coverage for ./Data/List/Stream.hs: 140/142 99% -Attaching instances... -Building cross-linking environment... -Renaming interfaces... -Warning: Data.Stream: could not find link destinations for: - Data.Stream.Unlifted GHC.Bool.Bool GHC.Types.Int GHC.Num.Num GHC.Classes.Ord Data.Maybe.Maybe GHC.Classes.Eq GHC.Ordering.Ordering GHC.Real.Integral GHC.Types.Char GHC.Integer.Type.Integer -Warning: Control.Monad.Stream: could not find link destinations for: - GHC.Types.IO Data.Maybe.Maybe GHC.Base.String GHC.Bool.Bool GHC.Types.Int -Warning: Data.List.Stream: could not find link destinations for: - GHC.Bool.Bool GHC.Types.Int GHC.Num.Num GHC.Classes.Ord Data.Maybe.Maybe GHC.Classes.Eq GHC.Base.String GHC.Ordering.Ordering GHC.Real.Integral -3 -Creating interfaces... -Checking module Data.Ranges... -Creating interface... -haddock coverage for ./Data/Ranges.hs: 6/10 60% -Attaching instances... -Building cross-linking environment... -Renaming interfaces... -Warning: Data.Ranges: could not find link destinations for: - GHC.Classes.Ord GHC.Classes.Eq GHC.Show.Show GHC.Bool.Bool Data.Set.Set -1 -leksah-server: ExitSuccess -Using default Yi configuration -^ -Warning: /home/Jon/Eclipse Workspace/JonShop/jonshop.cabal: A package using -'cabal-version: >=1.6' must use section syntax. See the Cabal user guide for -details. -user interrupt -Now updating system metadata ... -***server start -Bind 127.0.0.1:26411 -Now saving session -Metadata collector has nothing to do -Metadata collection has finished -***lost connection -***lost last connection - exiting -ExitSuccess -leksah-server: ExitSuccess -Using default Yi configuration -Warning: /home/Jon/Eclipse Workspace/JonShop/jonshop.cabal: A package using -'cabal-version: >=1.6' must use section syntax. See the Cabal user guide for -details. -Now updating system metadata ... -***server start -Bind 127.0.0.1:26411 -Metadata collector has nothing to do -Metadata collection has finished -Now loading metadata ... -Now updating workspace metadata ... - -/home/Jon/tls-0.7.1/Tests.hs:32:0: - error: missing binary operator before token "(" -Can't extract module /home/Jon/.leksah-0.10/metadata/tls-0.7.1/Main.lkshe leksah-server: phase `C pre-processor' failed (exitcode = 1) -Finished ->>>Info Changed!!! True -Now saving session -***lost connection -***lost last connection - exiting -ExitSuccess -leksah-server: ExitSuccess -Using default Yi configuration -Warning: /home/Jon/Eclipse Workspace/JonShop/jonshop.cabal: A package using -'cabal-version: >=1.6' must use section syntax. See the Cabal user guide for -details. -Now updating system metadata ... -***server start -Bind 127.0.0.1:26411 -Metadata collector has nothing to do -Metadata collection has finished -Now loading metadata ... -Now updating workspace metadata ... - -/home/Jon/tls-0.7.1/Tests.hs:32:0: - error: missing binary operator before token "(" -Can't extract module /home/Jon/.leksah-0.10/metadata/tls-0.7.1/Main.lkshe leksah-server: phase `C pre-processor' failed (exitcode = 1) -Finished ->>>Info Changed!!! True -Metadata collector has nothing to do -Metadata collection has finished - -/home/Jon/tls-0.7.1/Tests.hs:32:0: - error: missing binary operator before token "(" -Can't extract module /home/Jon/.leksah-0.10/metadata/tls-0.7.1/Main.lkshe leksah-server: phase `C pre-processor' failed (exitcode = 1) - -/home/Jon/tls-0.7.1/Tests.hs:32:0: - error: missing binary operator before token "(" -Can't extract module /home/Jon/.leksah-0.10/metadata/tls-0.7.1/Main.lkshe leksah-server: phase `C pre-processor' failed (exitcode = 1) -Now saving session -***lost connection -***lost connection -***lost last connection - exiting -***lost last connection - waiting -ExitSuccess -leksah-server: ExitSuccess -Using default Yi configuration -Warning: /home/Jon/Eclipse Workspace/JonShop/jonshop.cabal: A package using -'cabal-version: >=1.6' must use section syntax. See the Cabal user guide for -details. -Now updating system metadata ... -***server start -Bind 127.0.0.1:26411 -Metadata collector has nothing to do -Metadata collection has finished -Now loading metadata ... -Now updating workspace metadata ... - -/home/Jon/tls-0.7.1/Tests.hs:32:0: - error: missing binary operator before token "(" -Can't extract module /home/Jon/.leksah-0.10/metadata/tls-0.7.1/Main.lkshe leksah-server: phase `C pre-processor' failed (exitcode = 1) -Finished ->>>Info Changed!!! True - -(leksah:4413): IBUS-WARNING **: org.freedesktop.IBus.InputContext.GetEngine: GDBus.Error:org.freedesktop.DBus.Error.Failed: Input context does not have engine. - -(leksah:4413): IBUS-WARNING **: org.freedesktop.IBus.InputContext.GetEngine: GDBus.Error:org.freedesktop.DBus.Error.Failed: Input context does not have engine. - -(leksah:4413): IBUS-WARNING **: org.freedesktop.IBus.InputContext.GetEngine: GDBus.Error:org.freedesktop.DBus.Error.Failed: Input context does not have engine. - -(leksah:4413): IBUS-WARNING **: org.freedesktop.IBus.InputContext.GetEngine: GDBus.Error:org.freedesktop.DBus.Error.Failed: Input context does not have engine. -Now saving session -***lost connection -***lost last connection - exiting -ExitSuccess -leksah-server: ExitSuccess -Using default Yi configuration -Warning: /home/Jon/Eclipse Workspace/JonShop/jonshop.cabal: A package using -'cabal-version: >=1.6' must use section syntax. See the Cabal user guide for -details. -Now updating system metadata ... -***server start -Bind 127.0.0.1:26411 -Error reading cabal file "/home/Jon/.leksah-0.10/packageSources/blaze-builder-enumerator-0.2.0.2/blaze-builder-enumerator.cabal" "/home/Jon/.leksah-0.10/packageSources/blaze-builder-enumerator-0.2.0.2/blaze-builder-enumerator.cabal" (line 41, column 1): -unexpected end of input -expecting cabal minimal -update_toolbar 0.0 -update_toolbar 0.3333333333333333 ---2011-07-22 20:02:49-- http://www.leksah.org/metadata-0.10/dns-0.1.2.lkshm -Resolving www.leksah.org... 87.230.23.84 -Connecting to www.leksah.org|87.230.23.84|:80... connected. -HTTP request sent, awaiting response... 404 Not Found -2011-07-22 20:02:51 ERROR 404: Not Found. - -update_toolbar 0.6666666666666666 ---2011-07-22 20:02:57-- http://www.leksah.org/metadata-0.10/iproute-1.2.1.lkshm -Resolving www.leksah.org... 87.230.23.84 -Connecting to www.leksah.org|87.230.23.84|:80... connected. -HTTP request sent, awaiting response... 404 Not Found -2011-07-22 20:02:58 ERROR 404: Not Found. - -update_toolbar 1.0 ---2011-07-22 20:03:04-- http://www.leksah.org/metadata-0.10/appar-0.1.3.lkshm -Resolving www.leksah.org... 87.230.23.84 -Connecting to www.leksah.org|87.230.23.84|:80... connected. -HTTP request sent, awaiting response... 404 Not Found -2011-07-22 20:03:06 ERROR 404: Not Found. - -Metadata collection has finished -Now loading metadata ... -Now updating workspace metadata ... -Can't extract module /home/Jon/.leksah-0.10/metadata/tls-0.7.1/Main.lkshe : cannot satisfy -package-id crypto-api-0.6.1-0a41e3a14624d8945df29a18311dd5f5 - (use -v for more information) -Finished ->>>Info Changed!!! True -***lost connection -***lost last connection - exiting -***lost last connection - waiting -ExitSuccess -Creating interfaces... -Checking module Network.DNS.Internal... -Creating interface... -haddock coverage for ./Network/DNS/Internal.hs: 9/19 47% -Checking module Network.DNS.Types... -Creating interface... -haddock coverage for ./Network/DNS/Types.hs: 10/41 24% -Checking module Network.DNS.StateBinary... -Creating interface... -haddock coverage for ./Network/DNS/StateBinary.hs: 0/28 0% -Checking module Network.DNS.Query... -Creating interface... -haddock coverage for ./Network/DNS/Query.hs: 0/2 0% -Checking module Network.DNS.Response... -Creating interface... -haddock coverage for ./Network/DNS/Response.hs: 0/2 0% -Checking module Network.DNS.Resolver... -Creating interface... -haddock coverage for ./Network/DNS/Resolver.hs: 15/15 100% -Checking module Network.DNS.Lookup... -Creating interface... -haddock coverage for ./Network/DNS/Lookup.hs: 7/7 100% -Checking module Network.DNS... -Creating interface... -haddock coverage for ./Network/DNS.hs: 4/4 100% -Attaching instances... -Building cross-linking environment... -Renaming interfaces... -Warning: Network.DNS.Internal: could not find link destinations for: - GHC.Base.String GHC.Types.Int GHC.Classes.Eq GHC.Read.Read GHC.Show.Show Data.Maybe.Maybe GHC.Bool.Bool GHC.Enum.Enum Data.IP.Addr.IPv4 Data.IP.Addr.IPv6 Data.ByteString.Lazy.Internal.ByteString -Warning: Network.DNS.Types: could not find link destinations for: - GHC.Base.String GHC.Types.Int GHC.Classes.Eq GHC.Read.Read GHC.Show.Show GHC.Bool.Bool GHC.Enum.Enum Data.IP.Addr.IPv4 Data.IP.Addr.IPv6 Data.ByteString.Lazy.Internal.ByteString -Warning: Network.DNS.StateBinary: could not find link destinations for: - Control.Monad.Trans.State.Lazy.StateT Data.Binary.Get.Get Data.IntMap.IntMap GHC.Base.Monad Data.Binary.Put.Put GHC.Word.Word8 GHC.Word.Word16 GHC.Word.Word32 GHC.Types.Int Data.ByteString.Lazy.Internal.ByteString Data.Maybe.Maybe -Warning: Network.DNS.Query: could not find link destinations for: - GHC.Types.Int Data.ByteString.Lazy.Internal.ByteString -Warning: Network.DNS.Response: could not find link destinations for: - Data.ByteString.Lazy.Internal.ByteString -Warning: Network.DNS.Resolver: could not find link destinations for: - GHC.IO.FilePath Network.Socket.HostName GHC.Types.Int GHC.Int.Int64 GHC.Types.IO Data.Maybe.Maybe -Warning: Network.DNS.Lookup: could not find link destinations for: - GHC.Types.IO Data.Maybe.Maybe Data.IP.Addr.IPv4 Data.IP.Addr.IPv6 GHC.Types.Int Data.ByteString.Lazy.Internal.ByteString -8 -Creating interfaces... -Checking module Data.IP.Addr... -Creating interface... -haddock coverage for ./Data/IP/Addr.hs: 5/17 29% -Checking module Data.IP.Mask... -Creating interface... -haddock coverage for ./Data/IP/Mask.hs: 0/6 0% -Checking module Data.IP.Range... -Creating interface... -haddock coverage for ./Data/IP/Range.hs: 2/10 20% -Checking module Data.IP.Op... -Creating interface... -haddock coverage for ./Data/IP/Op.hs: 3/5 60% -Checking module Data.IP.RouteTable.Internal... -Creating interface... -haddock coverage for ./Data/IP/RouteTable/Internal.hs: 9/21 43% -Checking module Data.IP.RouteTable... -Creating interface... -haddock coverage for ./Data/IP/RouteTable.hs: 13/13 100% -Checking module Data.IP... -Creating interface... -haddock coverage for ./Data/IP.hs: 15/16 94% -Attaching instances... -Building cross-linking environment... -Renaming interfaces... -Warning: Data.IP.Addr: could not find link destinations for: - GHC.Classes.Eq GHC.Show.Show GHC.Word.Word32 GHC.Classes.Ord GHC.Read.Read Data.String.IsString GHC.Base.String GHC.Types.Int Text.Appar.String.Parser -Warning: Data.IP.Mask: could not find link destinations for: - GHC.Types.Int GHC.Word.Word32 Data.IntMap.IntMap -Warning: Data.IP.Range: could not find link destinations for: - GHC.Classes.Eq GHC.Read.Read GHC.Show.Show GHC.Types.Int GHC.Classes.Ord GHC.Base.String Text.Appar.String.Parser -Warning: Data.IP.Op: could not find link destinations for: - GHC.Classes.Eq GHC.Types.Int GHC.Bool.Bool -Warning: Data.IP.RouteTable.Internal: could not find link destinations for: - GHC.Types.Int GHC.Bool.Bool GHC.Word.Word32 Data.IntMap.IntMap Data.Maybe.Maybe GHC.Classes.Eq GHC.Show.Show -Warning: Data.IP.RouteTable: could not find link destinations for: - GHC.Types.Int GHC.Bool.Bool GHC.Classes.Eq GHC.Show.Show Data.Maybe.Maybe -Warning: Data.IP: could not find link destinations for: - GHC.Classes.Eq GHC.Show.Show GHC.Classes.Ord GHC.Read.Read Data.String.IsString GHC.Types.Int GHC.Bool.Bool -7 -Creating interfaces... -Checking module Text.Appar.Input... -Creating interface... -haddock coverage for ./Text/Appar/Input.hs: 1/2 50% -Checking module Text.Appar.Parser... -Creating interface... -Warning: Couldn't find .haddock for exported Text.Appar.Parser.<$>: base:Data.Functor.<$> -Warning: Couldn't find .haddock for exported Text.Appar.Parser.<$: base:GHC.Base.<$ -Warning: Couldn't find .haddock for exported Text.Appar.Parser.<*>: base:Control.Applicative.<*> -Warning: Couldn't find .haddock for exported Text.Appar.Parser.*>: base:Control.Applicative.*> -Warning: Couldn't find .haddock for exported Text.Appar.Parser.<*: base:Control.Applicative.<* -Warning: Couldn't find .haddock for exported Text.Appar.Parser.<**>: base:Control.Applicative.<**> -Warning: Couldn't find .haddock for exported Text.Appar.Parser.<|>: base:Control.Applicative.<|> -Warning: Couldn't find .haddock for exported Text.Appar.Parser.some: base:Control.Applicative.some -Warning: Couldn't find .haddock for exported Text.Appar.Parser.many: base:Control.Applicative.many -Warning: Couldn't find .haddock for exported Text.Appar.Parser.pure: base:Control.Applicative.pure -haddock coverage for ./Text/Appar/Parser.hs: 26/37 70% -Checking module Text.Appar.LazyByteString... -Creating interface... -haddock coverage for ./Text/Appar/LazyByteString.hs: 5/5 100% -Checking module Text.Appar.ByteString... -Creating interface... -haddock coverage for ./Text/Appar/ByteString.hs: 5/5 100% -Checking module Text.Appar.String... -Creating interface... -haddock coverage for ./Text/Appar/String.hs: 5/5 100% -Attaching instances... -Building cross-linking environment... -Renaming interfaces... -Warning: Text.Appar.Input: could not find link destinations for: - GHC.Classes.Eq GHC.Types.Char GHC.Bool.Bool GHC.Base.String Data.ByteString.Internal.ByteString Data.ByteString.Lazy.Internal.ByteString -Warning: Text.Appar.Parser: could not find link destinations for: - Data.ByteString.Lazy.Internal.ByteString Data.Maybe.Maybe GHC.Types.Char GHC.Base.String GHC.Base.Functor Control.Applicative.Applicative Control.Applicative.Alternative GHC.Base.Monad Control.Monad.MonadPlus GHC.Classes.Eq GHC.Bool.Bool Data.ByteString.Internal.ByteString -Warning: Text.Appar.LazyByteString: could not find link destinations for: - Data.ByteString.Lazy.Internal.ByteString -Warning: Text.Appar.ByteString: could not find link destinations for: - Data.ByteString.Internal.ByteString -Warning: Text.Appar.String: could not find link destinations for: - GHC.Base.String -5 -leksah-server: ExitSuccess -Now saving session -Using default Yi configuration -Warning: /home/Jon/Eclipse Workspace/JonShop/jonshop.cabal: A package using -'cabal-version: >=1.6' must use section syntax. See the Cabal user guide for -details. -Now updating system metadata ... -***server start -Bind 127.0.0.1:26411 -Metadata collector has nothing to do -Metadata collection has finished -Now loading metadata ... -Now updating workspace metadata ... -Can't extract module /home/Jon/.leksah-0.10/metadata/tls-0.7.1/Main.lkshe : cannot satisfy -package-id crypto-api-0.6.1-0a41e3a14624d8945df29a18311dd5f5 - (use -v for more information) -Finished ->>>Info Changed!!! True -Now saving session -***lost connection -***lost last connection - exiting -***lost last connection - waiting -ExitSuccess -leksah-server: ExitSuccess diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -1,67 +1,101 @@ -Name: pontarius-xmpp -Version: 0.0.7.0 -Cabal-Version: >= 1.6 -Build-Type: Simple -License: BSD3 -License-File: LICENSE -Copyright: Copyright © 2011, Jon Kristensen -Author: Jon Kristensen, Mahdi Abdinejadi -Maintainer: jon.kristensen@pontarius.org -Stability: alpha -Homepage: http://www.pontarius.org/ -Bug-Reports: mailto:info@pontarius.org --- Package-URL: -Synopsis: A prototyped and incomplete implementation of RFC 6120: - XMPP: Core -Description: A work in progress of an implementation of RFC 6120: XMPP: - Core, as well as RFC 6122: XMPP: Address Format and other - depending standards. A new version of Pontarius XMPP is - released every three weeks. -Category: Network -Tested-With: GHC ==7.0.2 +Name: pontarius-xmpp +Version: 0.1.0.0 +Cabal-Version: >= 1.6 +Build-Type: Simple +License: OtherLicense +License-File: LICENSE +Copyright: Dmitry Astapov, Pierre Kovalev, Mahdi Abdinejadi, Jon Kristensen, + IETF Trust, Philipp Balzarek +Author: Jon Kristensen, Mahdi Abdinejadi, Philipp Balzarek +Maintainer: info@jonkri.com +Stability: alpha +Homepage: http://www.pontarius.org/ +Bug-Reports: mailto:info@jonkri.com +Package-URL: http://hackage.haskell.org/packages/archive/pontarius-xmpp/0.1.0.0/pontarius-xmpp-0.1.0.0.tar.gz +Synopsis: An incomplete implementation of RFC 6120 (XMPP: Core) +Description: Pontarius is a work in progress implementation of + RFC 6120 (XMPP: Core). +Category: Network +Tested-With: GHC ==7.0.4, GHC ==7.4.1 -- Data-Files: -- Data-Dir: -- Extra-Source-Files: -- Extra-Tmp-Files: Library - Exposed-Modules: Network.XMPP - Exposed: True - Build-Depends: base >= 2 && < 5, parsec, enumerator, crypto-api ==0.6.3, - base64-string, pureMD5, utf8-string, network, xml-types, - text, transformers, bytestring, cereal ==0.3.3.0, random, - xml-enumerator, tls, tls-extra, containers, mtl, text-icu, - stringprep, asn1-data, cryptohash ==0.7.0, - time, certificate, ranges, uuid - -- Other-Modules: - -- HS-Source-Dirs: - -- Extensions: - -- Build-Tools: - -- Buildable: - -- GHC-Options: - -- GHC-Prof-Options: - -- Hugs-Options: - -- NHC98-Options: - -- Includes: - -- Install-Includes: - -- Include-Dirs: - -- C-Sources: - -- Extra-Libraries: - -- Extra-Lib-Dirs: - -- CC-Options: - -- LD-Options: - -- Pkgconfig-Depends: - -- Frameworks: + hs-source-dirs: source + Exposed: True + Build-Depends: base >4 && <5 + , conduit >=0.5 + , void >=0.5.5 + , resourcet >=0.3.0 + , containers >=0.4.0.0 + , random >=1.0.0.0 + , tls >=1.0.0 + , tls-extra >=0.5.0 + , pureMD5 >=2.1.2.1 + , base64-bytestring >=0.1.0.0 + , binary >=0.4.1 + , attoparsec >=0.10.0.3 + , crypto-api >=0.9 + , cryptohash >=0.6.1 + , text >=0.11.1.5 + , bytestring >=0.9.1.9 + , transformers >=0.2.2.0 + , mtl >=2.0.0.0 + , network >=2.3 + , lifted-base >=0.1.0.1 + , split >=0.1.2.3 + , stm >=2.1.2.1 + , xml-types >=0.3.1 + , xml-conduit >=1.0 + , xml-picklers >=0.2.2 + , data-default >=0.2 + , stringprep >=0.1.3 + Exposed-modules: Network.Xmpp + , Network.Xmpp.Bind + , Network.Xmpp.Concurrent + , Network.Xmpp.IM + , Network.Xmpp.Marshal + , Network.Xmpp.Monad + , Network.Xmpp.Message + , Network.Xmpp.Pickle + , Network.Xmpp.Presence + , Network.Xmpp.Sasl + , Network.Xmpp.Sasl.Mechanisms.Plain + , Network.Xmpp.Sasl.Mechanisms.DigestMd5 + , Network.Xmpp.Sasl.Mechanisms.Scram + , Network.Xmpp.Sasl.Types + , Network.Xmpp.Session + , Network.Xmpp.Stream + , Network.Xmpp.TLS + , Network.Xmpp.Types + , Network.Xmpp.Xep.ServiceDiscovery + Other-modules: + Network.Xmpp.Jid + , Network.Xmpp.Concurrent.Types + , Network.Xmpp.Concurrent.IQ + , Network.Xmpp.Concurrent.Threads + , Network.Xmpp.Concurrent.Monad + , Text.XML.Stream.Elements + , Data.Conduit.BufferedSource + , Data.Conduit.TLS + , Network.Xmpp.Sasl.Common + , Network.Xmpp.Sasl.StringPrep + , Network.Xmpp.Errors + GHC-Options: -Wall +Executable pontarius-xmpp-echoclient + hs-source-dirs: source + Main-Is: ../examples/EchoClient.hs + Source-Repository head - Type: darcs - -- Module: - Location: git://github.com/pontarius/pontarius-xmpp.git - -- Subdir: + Type: git + Location: git://github.com/jonkri/pontarius-xmpp.git Source-Repository this - Type: darcs + Type: git -- Module: - Location: git://github.com/pontarius/pontarius-xmpp.git - Tag: 0.0.7.0 + Location: git://github.com/jonkri/pontarius-xmpp.git + Tag: 0.1.0.0 -- Subdir: diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp.hs @@ -0,0 +1,250 @@ +-- | +-- Module: $Header$ +-- Description: A work in progress client implementation of RFC 6120 (XMPP: +-- Core). +-- License: Apache License 2.0 +-- +-- Maintainer: info@jonkri.com +-- Stability: unstable +-- Portability: portable +-- +-- The Extensible Messaging and Presence Protocol (XMPP) is an open technology +-- for near-real-time communication, which powers a wide range of applications +-- including instant messaging, presence, multi-party chat, voice and video +-- calls, collaboration, lightweight middleware, content syndication, and +-- generalized routing of XML data. XMPP provides a technology for the +-- asynchronous, end-to-end exchange of structured data by means of direct, +-- persistent XML streams among a distributed network of globally addressable, +-- presence-aware clients and servers. +-- +-- Pontarius is an XMPP client library, implementing the core capabilities of +-- XMPP (RFC 6120): setup and teardown of XML streams, channel encryption, +-- authentication, error handling, and communication primitives for messaging. +-- +-- 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. + +{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} + +module Network.Xmpp + ( -- * Session management + Session + , newSession + , withConnection + , connect + , simpleConnect + , startTLS + , simpleAuth + , auth + , closeConnection + , endSession + , setConnectionClosedHandler + -- * JID + , Jid(..) + , isBare + , isFull + -- * Stanzas + -- | The basic protocol data unit in XMPP is the XML stanza. The stanza is + -- essentially a fragment of XML that is sent over a stream. @Stanzas@ come in + -- 3 flavors: + -- + -- * @'Message'@, for traditional push-style message passing between peers + -- + -- * @'Presence'@, for communicating status updates + -- + -- * IQ (info/query), for request-response semantics communication + -- + -- All stanza types have the following attributes in common: + -- + -- * The /id/ attribute is used by the originating entity to track any + -- response or error stanza that it might receive in relation to the + -- generated stanza from another entity (such as an intermediate server or + -- the intended recipient). It is up to the originating entity whether the + -- value of the 'id' attribute is unique only within its current stream or + -- unique globally. + -- + -- * The /from/ attribute specifies the JID of the sender. + -- + -- * The /to/ attribute specifies the JID of the intended recipient for the + -- stanza. + -- + -- * The /type/ attribute specifies the purpose or context of the message, + -- presence, or IQ stanza. The particular allowable values for the 'type' + -- attribute vary depending on whether the stanza is a message, presence, + -- or IQ stanza. + , getStanzaChan + -- ** Messages + -- | The /message/ stanza is a /push/ mechanism whereby one entity pushes + -- information to another entity, similar to the communications that occur in + -- a system such as email. + -- + -- + , Message(..) + , MessageError(..) + , MessageType(..) + -- *** Creating + , answerMessage + -- *** Sending + , sendMessage + -- *** Receiving + , pullMessage + , waitForMessage + , waitForMessageError + , filterMessages + -- ** Presence + -- | XMPP includes the ability for an entity to advertise its network + -- availability, or "presence", to other entities. In XMPP, this availability + -- for communication is signaled end-to-end by means of a dedicated + -- communication primitive: the presence stanza. + , Presence(..) + , PresenceError(..) + -- *** Creating + , module Network.Xmpp.Presence + -- *** Sending + -- | Sends a presence stanza. In general, the presence stanza should have no + -- 'to' attribute, in which case the server to which the client is connected + -- will broadcast that stanza to all subscribed entities. However, a + -- publishing client may also send a presence stanza with a 'to' attribute, in + -- which case the server will route or deliver that stanza to the intended + -- recipient. + , sendPresence + -- *** Receiving + , pullPresence + , waitForPresence + -- ** IQ + -- | Info\/Query, or IQ, is a /request-response/ mechanism, similar in some + -- ways to the Hypertext Transfer Protocol @HTTP@. The semantics of IQ enable + -- an entity to make a request of, and receive a response from, another + -- entity. The data content and precise semantics of the request and response + -- is defined by the schema or other structural definition associated with the + -- XML namespace that qualifies the direct child element of the IQ element. IQ + -- interactions follow a common pattern of structured data exchange such as + -- get\/result or set\/result (although an error can be returned in reply to a + -- request if appropriate) + -- + -- + , IQRequest(..) + , IQRequestTicket + , iqRequestBody + , IQRequestType(..) + , IQResult(..) + , IQError(..) + , IQResponse(..) + , sendIQ + , sendIQ' + , answerIQ + , listenIQChan + , iqRequestPayload + , iqResultPayload + -- * Threads + , forkSession + -- * Miscellaneous + , LangTag(..) + , exampleParams + ) where + +import Data.Text as Text + +import Network +import qualified Network.TLS as TLS +import Network.Xmpp.Bind +import Network.Xmpp.Concurrent +import Network.Xmpp.Concurrent.Types +import Network.Xmpp.Marshal +import Network.Xmpp.Message +import Network.Xmpp.Monad +import Network.Xmpp.Pickle +import Network.Xmpp.Presence +import Network.Xmpp.Sasl +import Network.Xmpp.Sasl.Mechanisms +import Network.Xmpp.Sasl.Types +import Network.Xmpp.Session +import Network.Xmpp.Stream +import Network.Xmpp.TLS +import Network.Xmpp.Types + +import Control.Monad.Error + +-- | Connect to host with given address. +connect :: HostName -> Text -> XmppConMonad (Either StreamError ()) +connect address hostname = do + xmppRawConnect address hostname + result <- xmppStartStream + case result of + Left e -> do + pushElement . pickleElem xpStreamError $ toError e + xmppCloseStreams + return () + Right () -> return () + return result + where + -- TODO: Descriptive texts in stream errors? + toError (StreamNotStreamElement _name) = + XmppStreamError StreamInvalidXml Nothing Nothing + toError (StreamInvalidStreamNamespace _ns) = + XmppStreamError StreamInvalidNamespace Nothing Nothing + toError (StreamInvalidStreamPrefix _prefix) = + XmppStreamError StreamBadNamespacePrefix Nothing Nothing + -- TODO: Catch remaining xmppStartStream errors. + toError (StreamWrongVersion _ver) = + XmppStreamError StreamUnsupportedVersion Nothing Nothing + toError (StreamWrongLangTag _) = + XmppStreamError StreamInvalidXml Nothing Nothing + toError StreamUnknownError = + XmppStreamError StreamBadFormat Nothing Nothing + + +-- | Authenticate to the server using the first matching method and bind a +-- resource. +auth :: [SaslHandler] + -> Maybe Text + -> XmppConMonad (Either AuthError Jid) +auth mechanisms resource = runErrorT $ do + ErrorT $ xmppSasl mechanisms + jid <- lift $ xmppBind resource + lift $ xmppStartSession + return jid + +-- | Authenticate to the server with the given username and password +-- and bind a resource. +-- +-- Prefers SCRAM-SHA1 over DIGEST-MD5. +simpleAuth :: Text.Text -- ^ The username + -> Text.Text -- ^ The password + -> Maybe Text -- ^ The desired resource or 'Nothing' to let the + -- server assign one + -> XmppConMonad (Either AuthError Jid) +simpleAuth username passwd resource = flip auth resource $ + [ -- TODO: scramSha1Plus + scramSha1 username Nothing passwd + , digestMd5 username Nothing passwd + ] + + + +-- | The quick and easy way to set up a connection to an XMPP server +-- +-- This will +-- * connect to the host +-- * secure the connection with TLS +-- * authenticate to the server using either SCRAM-SHA1 (preferred) or +-- Digest-MD5 +-- * bind a resource +-- * return the full JID you have been assigned +-- +-- Note that the server might assign a different resource even when we send +-- a preference. +simpleConnect :: HostName -- ^ Target host name + -> Text -- ^ User name (authcid) + -> Text -- ^ Password + -> Maybe Text -- ^ Desired resource (or Nothing to let the server + -- decide) + -> XmppConMonad Jid +simpleConnect host username password resource = do + connect host username + startTLS exampleParams + saslResponse <- simpleAuth username password resource + case saslResponse of + Right jid -> return jid + Left e -> error $ show e diff --git a/source/Network/Xmpp/Bind.hs b/source/Network/Xmpp/Bind.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Bind.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_HADDOCK hide #-} + +module Network.Xmpp.Bind where + +import Control.Exception + +import Data.Text as Text +import Data.XML.Pickle +import Data.XML.Types + +import Network.Xmpp.Types +import Network.Xmpp.Pickle +import Network.Xmpp.Monad + +import Control.Monad.State(modify) + +-- Produces a `bind' element, optionally wrapping a resource. +bindBody :: Maybe Text -> Element +bindBody = pickleElem $ + -- Pickler to produce a + -- "" + -- element, with a possible "[JID]" + -- child. + xpBind . xpOption $ xpElemNodes "resource" (xpContent xpId) + +-- Sends a (synchronous) IQ set request for a (`Just') given or server-generated +-- resource and extract the JID from the non-error response. +xmppBind :: Maybe Text -> XmppConMonad Jid +xmppBind rsrc = do + answer <- xmppSendIQ' "bind" Nothing Set Nothing (bindBody rsrc) + jid <- case () of () | Right IQResult{iqResultPayload = Just b} <- answer + , Right jid <- unpickleElem xpJid b + -> return jid + | otherwise -> throw $ StreamXMLError + ("Bind couldn't unpickle JID from " ++ show answer) + modify (\s -> s{sJid = Just jid}) + return jid + where + -- Extracts the character data in the `jid' element. + xpJid :: PU [Node] Jid + xpJid = xpBind $ xpElemNodes jidName (xpContent xpPrim) + jidName = "{urn:ietf:params:xml:ns:xmpp-bind}jid" + +-- A `bind' element pickler. +xpBind :: PU [Node] b -> PU [Node] b +xpBind c = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-bind}bind" c diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Concurrent.hs @@ -0,0 +1,11 @@ +module Network.Xmpp.Concurrent + ( Session + , module Network.Xmpp.Concurrent.Monad + , module Network.Xmpp.Concurrent.Threads + , module Network.Xmpp.Concurrent.IQ + ) where + +import Network.Xmpp.Concurrent.Types +import Network.Xmpp.Concurrent.Monad +import Network.Xmpp.Concurrent.Threads +import Network.Xmpp.Concurrent.IQ diff --git a/source/Network/Xmpp/Concurrent/IQ.hs b/source/Network/Xmpp/Concurrent/IQ.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Concurrent/IQ.hs @@ -0,0 +1,81 @@ +module Network.Xmpp.Concurrent.IQ where + +import Control.Concurrent.STM +import Control.Concurrent (forkIO, threadDelay) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader + +import Data.XML.Types +import qualified Data.Map as Map + +import Network.Xmpp.Concurrent.Types +import Network.Xmpp.Concurrent.Monad +import Network.Xmpp.Types + +-- | Sends an IQ, returns a 'TMVar' that will be filled with the first inbound +-- IQ with a matching ID that has type @result@ or @error@. +sendIQ :: Maybe Int -- ^ Timeout + -> Maybe Jid -- ^ Recipient (to) + -> IQRequestType -- ^ IQ type (@Get@ or @Set@) + -> Maybe LangTag -- ^ Language tag of the payload (@Nothing@ for + -- default) + -> Element -- ^ The IQ body (there has to be exactly one) + -> Session + -> IO (TMVar IQResponse) +sendIQ timeOut to tp lang body session = do -- TODO: Add timeout + newId <- idGenerator session + ref <- atomically $ do + resRef <- newEmptyTMVar + (byNS, byId) <- readTVar (iqHandlers session) + writeTVar (iqHandlers session) (byNS, Map.insert newId resRef byId) + -- TODO: Check for id collisions (shouldn't happen?) + return resRef + sendStanza (IQRequestS $ IQRequest newId Nothing to lang tp body) session + case timeOut of + Nothing -> return () + Just t -> void . forkIO $ do + threadDelay t + doTimeOut (iqHandlers session) newId ref + return ref + where + doTimeOut handlers iqid var = atomically $ do + p <- tryPutTMVar var IQResponseTimeout + when p $ do + (byNS, byId) <- readTVar (iqHandlers session) + writeTVar handlers (byNS, Map.delete iqid byId) + return () + + +-- | Like 'sendIQ', but waits for the answer IQ. Times out after 3 seconds +sendIQ' :: Maybe Jid + -> IQRequestType + -> Maybe LangTag + -> Element + -> Session + -> IO IQResponse +sendIQ' to tp lang body session = do + ref <- sendIQ (Just 3000000) to tp lang body session + atomically $ takeTMVar ref + + +answerIQ :: IQRequestTicket + -> Either StanzaError (Maybe Element) + -> Session + -> IO Bool +answerIQ (IQRequestTicket + sentRef + (IQRequest iqid from _to lang _tp bd)) + answer session = do + let response = case answer of + Left err -> IQErrorS $ IQError iqid Nothing from lang err (Just bd) + Right res -> IQResultS $ IQResult iqid Nothing from lang res + atomically $ do + sent <- readTVar sentRef + case sent of + False -> do + writeTVar sentRef True + + writeTChan (outCh session) response + return True + True -> return False diff --git a/source/Network/Xmpp/Concurrent/Monad.hs b/source/Network/Xmpp/Concurrent/Monad.hs new file mode 100644 Binary files /dev/null and b/source/Network/Xmpp/Concurrent/Monad.hs differ diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Concurrent/Threads.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +module Network.Xmpp.Concurrent.Threads where + +import Network.Xmpp.Types + +import Control.Applicative((<$>),(<*>)) +import Control.Concurrent +import Control.Concurrent.STM +import qualified Control.Exception.Lifted as Ex +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Monad.State.Strict + +import qualified Data.ByteString as BS +import Data.IORef +import qualified Data.Map as Map +import Data.Maybe + +import Data.XML.Types + +import Network.Xmpp.Monad +import Network.Xmpp.Marshal +import Network.Xmpp.Pickle +import Network.Xmpp.Concurrent.Types + +import Text.XML.Stream.Elements + +import GHC.IO (unsafeUnmask) + +-- Worker to read stanzas from the stream and concurrently distribute them to +-- all listener threads. +readWorker :: TChan (Either MessageError Message) + -> TChan (Either PresenceError Presence) + -> TChan Stanza + -> TVar IQHandlers + -> TVar EventHandlers + -> TMVar XmppConnection + -> IO () +readWorker messageC presenceC stanzaC iqHands handlers stateRef = + Ex.mask_ . forever $ do + res <- liftIO $ Ex.catches ( do + -- we don't know whether pull will + -- necessarily be interruptible + s <- liftIO . atomically $ do + sr <- readTMVar stateRef + when (sConnectionState sr == XmppConnectionClosed) + retry + return sr + allowInterrupt + Just . fst <$> runStateT pullStanza s + ) + [ Ex.Handler $ \(Interrupt t) -> do + void $ handleInterrupts [t] + return Nothing + , Ex.Handler $ \(e :: StreamError) -> do + hands <- atomically $ readTVar handlers + _ <- forkIO $ connectionClosedHandler hands e + return Nothing + ] + liftIO . atomically $ do + case res of + Nothing -> return () + Just sta -> do + writeTChan stanzaC sta + void $ readTChan stanzaC -- sic + case sta of + MessageS m -> do writeTChan messageC $ Right m + _ <- readTChan messageC -- Sic! + return () + -- this may seem ridiculous, but to prevent + -- the channel from filling up we + -- immedtiately remove the + -- Stanza we just put in. It will still be + -- available in duplicates. + MessageErrorS m -> do writeTChan messageC $ Left m + _ <- readTChan messageC + return () + PresenceS p -> do + writeTChan presenceC $ Right p + _ <- readTChan presenceC + return () + PresenceErrorS p -> do + writeTChan presenceC $ Left p + _ <- readTChan presenceC + return () + + IQRequestS i -> handleIQRequest iqHands i + IQResultS i -> handleIQResponse iqHands (Right i) + IQErrorS i -> handleIQResponse iqHands (Left i) + + where + -- Defining an Control.Exception.allowInterrupt equivalent for GHC 7 + -- compatibility. + allowInterrupt :: IO () + allowInterrupt = unsafeUnmask $ return () + -- Call the connection closed handlers. + noCon :: TVar EventHandlers -> StreamError -> IO (Maybe a) + noCon h e = do + hands <- atomically $ readTVar h + _ <- forkIO $ connectionClosedHandler hands e + return Nothing + -- While waiting for the first semaphore(s) to flip we might receive another + -- interrupt. When that happens we add it's semaphore to the list and retry + -- waiting. We do this because we might receive another + -- interrupt while we're waiting for a mutex to unlock; if that happens, the + -- new interrupt is added to the list and is waited for as well. + handleInterrupts :: [TMVar ()] -> IO [()] + handleInterrupts ts = + Ex.catch (atomically $ forM ts takeTMVar) + (\(Interrupt t) -> handleInterrupts (t:ts)) + +-- If the IQ request has a namespace, sent it through the appropriate channel. +handleIQRequest :: TVar IQHandlers -> IQRequest -> STM () +handleIQRequest handlers iq = do + (byNS, _) <- readTVar handlers + let iqNS = fromMaybe "" (nameNamespace . elementName $ iqRequestPayload iq) + case Map.lookup (iqRequestType iq, iqNS) byNS of + Nothing -> return () -- TODO: send error stanza + Just ch -> do + sent <- newTVar False + writeTChan ch $ IQRequestTicket sent iq + +handleIQResponse :: TVar IQHandlers -> Either IQError IQResult -> STM () +handleIQResponse handlers iq = do + (byNS, byID) <- readTVar handlers + case Map.updateLookupWithKey (\_ _ -> Nothing) (iqID iq) byID of + (Nothing, _) -> return () -- We are not supposed to send an error. + (Just tmvar, byID') -> do + let answer = either IQResponseError IQResponseResult iq + _ <- tryPutTMVar tmvar answer -- Don't block. + writeTVar handlers (byNS, byID') + where + iqID (Left err) = iqErrorID err + iqID (Right iq') = iqResultID iq' + +-- Worker to write stanzas to the stream concurrently. +writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO Bool) -> IO () +writeWorker stCh writeR = forever $ do + (write, next) <- atomically $ (,) <$> + takeTMVar writeR <*> + readTChan stCh + r <- write $ renderElement (pickleElem xpStanza next) + atomically $ putTMVar writeR write + unless r $ do + atomically $ unGetTChan stCh next -- If the writing failed, the + -- connection is dead. + threadDelay 250000 -- Avoid free spinning. + + + + +-- Two streams: input and output. Threads read from input stream and write to +-- output stream. +-- | Runs thread in XmppState monad. Returns channel of incoming and outgoing +-- stances, respectively, and an Action to stop the Threads and close the +-- connection. +startThreads :: IO ( TChan (Either MessageError Message) + , TChan (Either PresenceError Presence) + , TChan Stanza + , TVar IQHandlers + , TChan Stanza + , IO () + , TMVar (BS.ByteString -> IO Bool) + , TMVar XmppConnection + , ThreadId + , TVar EventHandlers + ) +startThreads = do + writeLock <- newTMVarIO (\_ -> return False) + messageC <- newTChanIO + presenceC <- newTChanIO + outC <- newTChanIO + stanzaC <- newTChanIO + handlers <- newTVarIO (Map.empty, Map.empty) + eh <- newTVarIO zeroEventHandlers + conS <- newTMVarIO xmppNoConnection + lw <- forkIO $ writeWorker outC writeLock + cp <- forkIO $ connPersist writeLock + rd <- forkIO $ readWorker messageC presenceC stanzaC handlers eh conS + return ( messageC + , presenceC + , stanzaC + , handlers + , outC + , killConnection writeLock [lw, rd, cp] + , writeLock + , conS + , rd + , eh) + where + killConnection writeLock threads = liftIO $ do + _ <- atomically $ takeTMVar writeLock -- Should we put it back? + _ <- forM threads killThread + return () + zeroEventHandlers :: EventHandlers + zeroEventHandlers = EventHandlers + { connectionClosedHandler = \_ -> return () + } + +-- | Initializes a new XMPP session. +newSession :: IO Session +newSession = do + (mC, pC, sC, hand, outC, stopThreads', writeR, conS, rdr, eh) <- startThreads + workermCh <- newIORef $ Nothing + workerpCh <- newIORef $ Nothing + idRef <- newTVarIO 1 + let getId = atomically $ do + curId <- readTVar idRef + writeTVar idRef (curId + 1 :: Integer) + return . read. show $ curId + return $ Session + mC + pC + sC + workermCh + workerpCh + outC + hand + writeR + rdr + getId + conS + eh + stopThreads' + +-- Acquires the write lock, pushes a space, and releases the lock. +-- | Sends a blank space every 30 seconds to keep the connection alive. +connPersist :: TMVar (BS.ByteString -> IO Bool) -> IO () +connPersist lock = forever $ do + pushBS <- atomically $ takeTMVar lock + _ <- pushBS " " + atomically $ putTMVar lock pushBS + threadDelay 30000000 -- 30s diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -0,0 +1,71 @@ +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Network.Xmpp.Concurrent.Types where + +import qualified Control.Exception.Lifted as Ex +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad.Trans.Reader + +import qualified Data.ByteString as BS +import Data.IORef +import qualified Data.Map as Map +import Data.Text(Text) +import Data.Typeable + +import Network.Xmpp.Types + +-- Map between the IQ request type and the "query" namespace pair, and the TChan +-- for the IQ request and "sent" boolean pair. +type IQHandlers = (Map.Map (IQRequestType, Text) (TChan IQRequestTicket) + , Map.Map StanzaId (TMVar IQResponse) + ) + +-- Handlers to be run when the Xmpp session ends and when the Xmpp connection is +-- closed. +data EventHandlers = EventHandlers + { connectionClosedHandler :: StreamError -> IO () + } + +-- The Session object is the Xmpp (ReaderT) state. +data Session = Session + { -- The original master channels that the reader puts stanzas + -- into. These are cloned by @get{STanza,Message,Presence}Chan + -- on demand when first used by the thread and are stored in the + -- {message,presence}Ref fields below. + mShadow :: TChan (Either MessageError Message) + , pShadow :: TChan (Either PresenceError Presence) + , sShadow :: TChan Stanza -- All stanzas + -- The cloned copies of the original/shadow channels. They are + -- thread-local (as opposed to the shadow channels) and contains all + -- stanzas received after the cloning of the shadow channels. + , messagesRef :: IORef (Maybe (TChan (Either MessageError Message))) + , presenceRef :: IORef (Maybe (TChan (Either PresenceError Presence))) + , outCh :: TChan Stanza + , iqHandlers :: TVar IQHandlers + -- Writing lock, so that only one thread could write to the stream at any + -- given time. + , writeRef :: TMVar (BS.ByteString -> IO Bool) + , readerThread :: ThreadId + , idGenerator :: IO StanzaId + -- Lock (used by withConnection) to make sure that a maximum of one + -- XmppConMonad calculation is executed at any given time. + , conStateRef :: TMVar XmppConnection + , eventHandlers :: TVar EventHandlers + , stopThreads :: IO () + } + + +-- Interrupt is used to signal to the reader thread that it should stop. +data Interrupt = Interrupt (TMVar ()) deriving Typeable +instance Show Interrupt where show _ = "" + +instance Ex.Exception Interrupt + +-- | Contains whether or not a reply has been sent, and the IQ request body to +-- reply to. +data IQRequestTicket = IQRequestTicket + { sentRef :: (TVar Bool) + , iqRequestBody :: IQRequest + } diff --git a/source/Network/Xmpp/Errors.hs b/source/Network/Xmpp/Errors.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Errors.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +module Network.Xmpp.Errors where + +import Control.Applicative ((<$>)) +import Control.Monad(unless) +import Control.Monad.Error +import Control.Monad.Error.Class +import qualified Data.Text as Text +import Data.XML.Types +import Network.Xmpp.Types +import Network.Xmpp.Pickle + + +-- Finds unpickling problems. Not to be used for data validation +findStreamErrors :: Element -> StreamError +findStreamErrors (Element name attrs children) + | (nameLocalName name /= "stream") + = StreamNotStreamElement $ nameLocalName name + | (nameNamespace name /= Just "http://etherx.jabber.org/streams") + = StreamInvalidStreamNamespace $ nameNamespace name + | otherwise = checkchildren (flattenAttrs attrs) + where + checkchildren children = + let to' = lookup "to" children + ver' = lookup "version" children + xl = lookup xmlLang children + in case () of () | Just (Nothing :: Maybe Jid) == (safeRead <$> to') + -> StreamWrongTo to' + | Nothing == ver' + -> StreamWrongVersion Nothing + | Just (Nothing :: Maybe LangTag) == + (safeRead <$> xl) + -> StreamWrongLangTag xl + | otherwise + -> StreamUnknownError + safeRead x = case reads $ Text.unpack x of + [] -> Nothing + [(y,_),_] -> Just y + +flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)] +flattenAttrs attrs = map (\(name, content) -> + ( name + , Text.concat $ map uncontentify content) + ) + attrs + where + uncontentify (ContentText t) = t + uncontentify _ = "" diff --git a/source/Network/Xmpp/IM.hs b/source/Network/Xmpp/IM.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/IM.hs @@ -0,0 +1,7 @@ +module Network.Xmpp.IM + ( module Network.Xmpp.IM.Message + , module Network.Xmpp.IM.Presence + ) where + +import Network.Xmpp.IM.Message +import Network.Xmpp.IM.Presence diff --git a/source/Network/Xmpp/Jid.hs b/source/Network/Xmpp/Jid.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Jid.hs @@ -0,0 +1,205 @@ +{-# OPTIONS_HADDOCK hide #-} + +-- This module deals with JIDs, also known as XMPP addresses. For more +-- information on JIDs, see RFC 6122: XMPP: Address Format. + +module Network.Xmpp.Jid + ( Jid(..) + , fromText + , fromStrings + , isBare + , isFull + ) where + +import Control.Applicative ((<$>),(<|>)) +import Control.Monad(guard) + +import qualified Data.Attoparsec.Text as AP +import Data.Maybe(fromJust) +import qualified Data.Set as Set +import Data.String (IsString(..)) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Text.NamePrep as SP +import qualified Text.StringPrep as SP + +-- | A JID is XMPP\'s native format for addressing entities in the network. It +-- is somewhat similar to an e-mail address but contains three parts instead of +-- two. +data Jid = Jid { -- | The @localpart@ of a JID is an optional identifier placed + -- before the domainpart and separated from the latter by a + -- \'\@\' character. Typically a localpart uniquely identifies + -- the entity requesting and using network access provided by a + -- server (i.e., a local account), although it can also + -- represent other kinds of entities (e.g., a chat room + -- associated with a multi-user chat service). The entity + -- represented by an XMPP localpart is addressed within the + -- context of a specific domain (i.e., + -- @localpart\@domainpart@). + localpart :: !(Maybe Text) + + -- | The domainpart typically identifies the /home/ server to + -- which clients connect for XML routing and data management + -- functionality. However, it is not necessary for an XMPP + -- domainpart to identify an entity that provides core XMPP + -- server functionality (e.g., a domainpart can identify an + -- entity such as a multi-user chat service, a + -- publish-subscribe service, or a user directory). + , domainpart :: !Text + + -- | The resourcepart of a JID is an optional identifier placed + -- after the domainpart and separated from the latter by the + -- \'\/\' character. A resourcepart can modify either a + -- @localpart\@domainpart@ address or a mere @domainpart@ + -- address. Typically a resourcepart uniquely identifies a + -- specific connection (e.g., a device or location) or object + -- (e.g., an occupant in a multi-user chat room) belonging to + -- the entity associated with an XMPP localpart at a domain + -- (i.e., @localpart\@domainpart/resourcepart@). + , resourcepart :: !(Maybe Text) + } deriving Eq + +instance Show Jid where + show (Jid nd dmn res) = + maybe "" ((++ "@") . Text.unpack) nd ++ Text.unpack dmn ++ + maybe "" (('/' :) . Text.unpack) res + +instance Read Jid where + readsPrec _ x = case fromText (Text.pack x) of + Nothing -> [] + Just j -> [(j,"")] + +instance IsString Jid where + fromString = fromJust . fromText . Text.pack + +-- | Converts a Text to a JID. +fromText :: Text -> Maybe Jid +fromText t = do + (l, d, r) <- eitherToMaybe $ AP.parseOnly jidParts t + fromStrings l d r + where + eitherToMaybe = either (const Nothing) Just + +-- | Converts localpart, domainpart, and resourcepart strings to a JID. Runs the +-- appropriate stringprep profiles and validates the parts. +fromStrings :: Maybe Text -> Text -> Maybe Text -> Maybe Jid +fromStrings l d r = do + localPart <- case l of + Nothing -> return Nothing + Just l'-> do + l'' <- SP.runStringPrep nodeprepProfile l' + guard $ validPartLength l'' + let prohibMap = Set.fromList nodeprepExtraProhibitedCharacters + guard $ Text.all (`Set.notMember` prohibMap) l'' + return $ Just l'' + domainPart <- SP.runStringPrep (SP.namePrepProfile False) d + guard $ validDomainPart domainPart + resourcePart <- case r of + Nothing -> return Nothing + Just r' -> do + r'' <- SP.runStringPrep resourceprepProfile r' + guard $ validPartLength r'' + return $ Just r'' + return $ Jid localPart domainPart resourcePart + where + validDomainPart :: Text -> Bool + validDomainPart _s = True -- TODO + + validPartLength :: Text -> Bool + validPartLength p = Text.length p > 0 && Text.length p < 1024 + +-- | Returns 'True' if the JID is /bare/, and 'False' otherwise. +isBare :: Jid -> Bool +isBare j | resourcepart j == Nothing = True + | otherwise = False + +-- | Returns 'True' if the JID is /full/, and 'False' otherwise. +isFull :: Jid -> Bool +isFull = not . isBare + +-- Parses an JID string and returns its three parts. It performs no validation +-- or transformations. +jidParts :: AP.Parser (Maybe Text, Text, Maybe Text) +jidParts = do + -- Read until we reach an '@', a '/', or EOF. + a <- AP.takeWhile1 (AP.notInClass ['@', '/']) + -- Case 1: We found an '@', and thus the localpart. At least the domainpart + -- is remaining. Read the '@' and until a '/' or EOF. + do + b <- domainPartP + -- Case 1A: We found a '/' and thus have all the JID parts. Read the '/' + -- and until EOF. + do + c <- resourcePartP -- Parse resourcepart + return (Just a, b, Just c) + -- Case 1B: We have reached EOF; the JID is in the form + -- localpart@domainpart. + <|> do + AP.endOfInput + return (Just a, b, Nothing) + -- Case 2: We found a '/'; the JID is in the form + -- domainpart/resourcepart. + <|> do + b <- resourcePartP + AP.endOfInput + return (Nothing, a, Just b) + -- Case 3: We have reached EOF; we have an JID consisting of only a + -- domainpart. + <|> do + AP.endOfInput + return (Nothing, a, Nothing) + where + -- Read an '@' and everything until a '/'. + domainPartP :: AP.Parser Text + domainPartP = do + _ <- AP.char '@' + AP.takeWhile1 (/= '/') + -- Read everything until a '/'. + resourcePartP :: AP.Parser Text + resourcePartP = do + _ <- AP.char '/' + AP.takeText + +-- The `nodeprep' StringPrep profile. +nodeprepProfile :: SP.StringPrepProfile +nodeprepProfile = SP.Profile { SP.maps = [SP.b1, SP.b2] + , SP.shouldNormalize = True + , SP.prohibited = [SP.a1 + , SP.c11 + , SP.c12 + , SP.c21 + , SP.c22 + , SP.c3 + , SP.c4 + , SP.c5 + , SP.c6 + , SP.c7 + , SP.c8 + , SP.c9 + ] + , SP.shouldCheckBidi = True + } + +-- These characters needs to be checked for after normalization. +nodeprepExtraProhibitedCharacters :: [Char] +nodeprepExtraProhibitedCharacters = ['\x22', '\x26', '\x27', '\x2F', '\x3A', + '\x3C', '\x3E', '\x40'] + +-- The `resourceprep' StringPrep profile. +resourceprepProfile :: SP.StringPrepProfile +resourceprepProfile = SP.Profile { SP.maps = [SP.b1] + , SP.shouldNormalize = True + , SP.prohibited = [ SP.a1 + , SP.c12 + , SP.c21 + , SP.c22 + , SP.c3 + , SP.c4 + , SP.c5 + , SP.c6 + , SP.c7 + , SP.c8 + , SP.c9 + ] + , SP.shouldCheckBidi = True + } diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Marshal.hs @@ -0,0 +1,209 @@ +-- Picklers and unpicklers convert Haskell data to XML and XML to Haskell data, +-- respectively. By convensions, pickler/unpickler ("PU") function names start +-- out with "xp". + +{-# Language OverloadedStrings, ViewPatterns, NoMonomorphismRestriction #-} + +{-# OPTIONS_HADDOCK hide #-} + +module Network.Xmpp.Marshal where + +import Data.XML.Pickle +import Data.XML.Types + +import Network.Xmpp.Pickle +import Network.Xmpp.Types + +xpStreamStanza :: PU [Node] (Either XmppStreamError Stanza) +xpStreamStanza = xpEither xpStreamError xpStanza + +xpStanza :: PU [Node] Stanza +xpStanza = xpAlt stanzaSel + [ xpWrap IQRequestS (\(IQRequestS x) -> x) xpIQRequest + , xpWrap IQResultS (\(IQResultS x) -> x) xpIQResult + , xpWrap IQErrorS (\(IQErrorS x) -> x) xpIQError + , xpWrap MessageS (\(MessageS x) -> x) xpMessage + , xpWrap MessageErrorS (\(MessageErrorS x) -> x) xpMessageError + , xpWrap PresenceS (\(PresenceS x) -> x) xpPresence + , xpWrap PresenceErrorS (\(PresenceErrorS x) -> x) xpPresenceError + ] + where + -- Selector for which pickler to execute above. + stanzaSel :: Stanza -> Int + stanzaSel (IQRequestS _) = 0 + stanzaSel (IQResultS _) = 1 + stanzaSel (IQErrorS _) = 2 + stanzaSel (MessageS _) = 3 + stanzaSel (MessageErrorS _) = 4 + stanzaSel (PresenceS _) = 5 + stanzaSel (PresenceErrorS _) = 6 + +xpMessage :: PU [Node] (Message) +xpMessage = xpWrap + (\((tp, qid, from, to, lang), ext) -> Message qid from to lang tp ext) + (\(Message qid from to lang tp ext) -> ((tp, qid, from, to, lang), ext)) + (xpElem "{jabber:client}message" + (xp5Tuple + (xpDefault Normal $ xpAttr "type" xpPrim) + (xpAttrImplied "id" xpPrim) + (xpAttrImplied "from" xpPrim) + (xpAttrImplied "to" xpPrim) + xpLangTag + -- TODO: NS? + ) + (xpAll xpElemVerbatim) + ) + +xpPresence :: PU [Node] Presence +xpPresence = xpWrap + (\((qid, from, to, lang, tp), ext) -> Presence qid from to lang tp ext) + (\(Presence qid from to lang tp ext) -> ((qid, from, to, lang, tp), ext)) + (xpElem "{jabber:client}presence" + (xp5Tuple + (xpAttrImplied "id" xpPrim) + (xpAttrImplied "from" xpPrim) + (xpAttrImplied "to" xpPrim) + xpLangTag + (xpAttrImplied "type" xpPrim) + ) + (xpAll xpElemVerbatim) + ) + +xpIQRequest :: PU [Node] IQRequest +xpIQRequest = xpWrap + (\((qid, from, to, lang, tp),body) -> IQRequest qid from to lang tp body) + (\(IQRequest qid from to lang tp body) -> ((qid, from, to, lang, tp), body)) + (xpElem "{jabber:client}iq" + (xp5Tuple + (xpAttr "id" xpPrim) + (xpAttrImplied "from" xpPrim) + (xpAttrImplied "to" xpPrim) + xpLangTag + ((xpAttr "type" xpPrim)) + ) + xpElemVerbatim + ) + +xpIQResult :: PU [Node] IQResult +xpIQResult = xpWrap + (\((qid, from, to, lang, _tp),body) -> IQResult qid from to lang body) + (\(IQResult qid from to lang body) -> ((qid, from, to, lang, ()), body)) + (xpElem "{jabber:client}iq" + (xp5Tuple + (xpAttr "id" xpPrim) + (xpAttrImplied "from" xpPrim) + (xpAttrImplied "to" xpPrim) + xpLangTag + ((xpAttrFixed "type" "result")) + ) + (xpOption xpElemVerbatim) + ) + +---------------------------------------------------------- +-- Errors +---------------------------------------------------------- + +xpErrorCondition :: PU [Node] StanzaErrorCondition +xpErrorCondition = xpWrap + (\(cond, (), ()) -> cond) + (\cond -> (cond, (), ())) + (xpElemByNamespace + "urn:ietf:params:xml:ns:xmpp-stanzas" + xpPrim + xpUnit + xpUnit + ) + +xpStanzaError :: PU [Node] StanzaError +xpStanzaError = xpWrap + (\(tp, (cond, txt, ext)) -> StanzaError tp cond txt ext) + (\(StanzaError tp cond txt ext) -> (tp, (cond, txt, ext))) + (xpElem "{jabber:client}error" + (xpAttr "type" xpPrim) + (xp3Tuple + xpErrorCondition + (xpOption $ xpElem "{jabber:client}text" + (xpAttrImplied xmlLang xpPrim) + (xpContent xpId) + ) + (xpOption xpElemVerbatim) + ) + ) + +xpMessageError :: PU [Node] (MessageError) +xpMessageError = xpWrap + (\((_, qid, from, to, lang), (err, ext)) -> + MessageError qid from to lang err ext) + (\(MessageError qid from to lang err ext) -> + (((), qid, from, to, lang), (err, ext))) + (xpElem "{jabber:client}message" + (xp5Tuple + (xpAttrFixed "type" "error") + (xpAttrImplied "id" xpPrim) + (xpAttrImplied "from" xpPrim) + (xpAttrImplied "to" xpPrim) + (xpAttrImplied xmlLang xpPrim) + -- TODO: NS? + ) + (xp2Tuple xpStanzaError (xpAll xpElemVerbatim)) + ) + +xpPresenceError :: PU [Node] PresenceError +xpPresenceError = xpWrap + (\((qid, from, to, lang, _),(err, ext)) -> + PresenceError qid from to lang err ext) + (\(PresenceError qid from to lang err ext) -> + ((qid, from, to, lang, ()), (err, ext))) + (xpElem "{jabber:client}presence" + (xp5Tuple + (xpAttrImplied "id" xpPrim) + (xpAttrImplied "from" xpPrim) + (xpAttrImplied "to" xpPrim) + xpLangTag + (xpAttrFixed "type" "error") + ) + (xp2Tuple xpStanzaError (xpAll xpElemVerbatim)) + ) + +xpIQError :: PU [Node] IQError +xpIQError = xpWrap + (\((qid, from, to, lang, _tp),(err, body)) -> + IQError qid from to lang err body) + (\(IQError qid from to lang err body) -> + ((qid, from, to, lang, ()), (err, body))) + (xpElem "{jabber:client}iq" + (xp5Tuple + (xpAttr "id" xpPrim) + (xpAttrImplied "from" xpPrim) + (xpAttrImplied "to" xpPrim) + xpLangTag + ((xpAttrFixed "type" "error")) + ) + (xp2Tuple xpStanzaError (xpOption xpElemVerbatim)) + ) + +xpStreamError :: PU [Node] XmppStreamError +xpStreamError = xpWrap + (\((cond,() ,()), txt, el) -> XmppStreamError cond txt el) + (\(XmppStreamError cond txt el) ->((cond,() ,()), txt, el)) + (xpElemNodes + (Name + "error" + (Just "http://etherx.jabber.org/streams") + (Just "stream") + ) + (xp3Tuple + (xpElemByNamespace + "urn:ietf:params:xml:ns:xmpp-streams" + xpPrim + xpUnit + xpUnit + ) + (xpOption $ xpElem + "{urn:ietf:params:xml:ns:xmpp-streams}text" + xpLangTag + (xpContent xpId) + ) + (xpOption xpElemVerbatim) -- Application specific error conditions + ) + ) diff --git a/source/Network/Xmpp/Message.hs b/source/Network/Xmpp/Message.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Message.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE RecordWildCards #-} +module Network.Xmpp.Message + ( Message(..) + , MessageError(..) + , MessageType(..) + , answerMessage + , message + ) where + +import Data.XML.Types + +import Network.Xmpp.Types + +-- | An empty message. +message :: Message +message = Message { messageID = Nothing + , messageFrom = Nothing + , messageTo = Nothing + , messageLangTag = Nothing + , messageType = Normal + , messagePayload = [] + } + +-- Produce an answer message with the given payload, switching the "from" and +-- "to" attributes in the original message. +answerMessage :: Message -> [Element] -> Maybe Message +answerMessage Message{messageFrom = Just frm, ..} payload = + Just Message{ messageFrom = messageTo + , messageID = Nothing + , messageTo = Just frm + , messagePayload = payload + , .. + } +answerMessage _ _ = Nothing diff --git a/source/Network/Xmpp/Monad.hs b/source/Network/Xmpp/Monad.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Monad.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.Xmpp.Monad where + +import Control.Applicative((<$>)) +import Control.Concurrent (forkIO, threadDelay) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +--import Control.Monad.Trans.Resource +import qualified Control.Exception.Lifted as Ex +import qualified GHC.IO.Exception as GIE +import Control.Monad.State.Strict + +import Data.ByteString as BS +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.Conduit.BufferedSource +import Data.Conduit.Binary as CB +import Data.Text(Text) +import Data.XML.Pickle +import Data.XML.Types + +import Network +import Network.Xmpp.Types +import Network.Xmpp.Marshal +import Network.Xmpp.Pickle + +import System.IO + +import Text.XML.Stream.Elements +import Text.XML.Stream.Parse as XP +import Text.XML.Unresolved(InvalidEventStream(..)) + +-- Enable/disable debug output +-- This will dump all incoming and outgoing network taffic to the console, +-- prefixed with "in: " and "out: " respectively +debug :: Bool +debug = False + +pushElement :: Element -> XmppConMonad Bool +pushElement x = do + sink <- gets sConPushBS + liftIO . sink $ renderElement x + +pushStanza :: Stanza -> XmppConMonad Bool +pushStanza = pushElement . pickleElem xpStanza + +-- XML documents and XMPP streams SHOULD be preceeded by an XML declaration. +-- UTF-8 is the only supported XMPP encoding. The standalone document +-- declaration (matching "SDDecl" in the XML standard) MUST NOT be included in +-- XMPP streams. RFC 6120 defines XMPP only in terms of XML 1.0. +pushXmlDecl :: XmppConMonad Bool +pushXmlDecl = do + sink <- gets sConPushBS + liftIO $ sink "" + +pushOpenElement :: Element -> XmppConMonad Bool +pushOpenElement e = do + sink <- gets sConPushBS + liftIO . sink $ renderOpenElement e + +-- `Connect-and-resumes' the given sink to the connection source, and pulls a +-- `b' value. +pullToSink :: Sink Event IO b -> XmppConMonad b +pullToSink snk = do + source <- gets sConSrc + (_, r) <- lift $ source $$+ snk + return r + +pullElement :: XmppConMonad Element +pullElement = do + Ex.catches (do + e <- pullToSink (elements =$ CL.head) + case e of + Nothing -> liftIO $ Ex.throwIO StreamConnectionError + Just r -> return r + ) + [ Ex.Handler (\StreamEnd -> Ex.throwIO StreamStreamEnd) + , Ex.Handler (\(InvalidXmppXml s) + -> liftIO . Ex.throwIO $ StreamXMLError s) + , Ex.Handler $ \(e :: InvalidEventStream) + -> liftIO . Ex.throwIO $ StreamXMLError (show e) + + ] + +-- Pulls an element and unpickles it. +pullPickle :: PU [Node] a -> XmppConMonad a +pullPickle p = do + res <- unpickleElem p <$> pullElement + case res of + Left e -> liftIO . Ex.throwIO $ StreamXMLError (show e) + Right r -> return r + +-- Pulls a stanza (or stream error) from the stream. Throws an error on a stream +-- error. +pullStanza :: XmppConMonad Stanza +pullStanza = do + res <- pullPickle xpStreamStanza + case res of + Left e -> liftIO . Ex.throwIO $ StreamError e + Right r -> return r + +-- Performs the given IO operation, catches any errors and re-throws everything +-- except 'ResourceVanished' and IllegalOperation, in which case it will return False instead +catchPush :: IO () -> IO Bool +catchPush p = Ex.catch + (p >> return True) + (\e -> case GIE.ioe_type e of + GIE.ResourceVanished -> return False + GIE.IllegalOperation -> return False + _ -> Ex.throwIO e + ) + +-- XmppConnection state used when there is no connection. +xmppNoConnection :: XmppConnection +xmppNoConnection = XmppConnection + { sConSrc = zeroSource + , sRawSrc = zeroSource + , sConPushBS = \_ -> return False -- Nothing has been sent. + , sConHandle = Nothing + , sFeatures = SF Nothing [] [] + , sConnectionState = XmppConnectionClosed + , sHostname = Nothing + , sJid = Nothing + , sCloseConnection = return () + , sStreamLang = Nothing + , sStreamId = Nothing + , sPreferredLang = Nothing + , sToJid = Nothing + , sJidWhenPlain = False + , sFrom = Nothing + } + where + zeroSource :: Source IO output + zeroSource = liftIO . Ex.throwIO $ StreamConnectionError + +-- Connects to the given hostname on port 5222 (TODO: Make this dynamic) and +-- updates the XmppConMonad XmppConnection state. +xmppRawConnect :: HostName -> Text -> XmppConMonad () +xmppRawConnect host hostname = do + con <- liftIO $ do + con <- connectTo host (PortNumber 5222) + hSetBuffering con NoBuffering + return con + let raw = if debug + then sourceHandle con $= debugConduit + else sourceHandle con + src <- liftIO . bufferSource $ raw $= XP.parseBytes def + let st = XmppConnection + { sConSrc = src + , sRawSrc = raw + , sConPushBS = if debug + then \d -> do + BS.putStrLn (BS.append "out: " d) + catchPush $ BS.hPut con d + else catchPush . BS.hPut con + , sConHandle = (Just con) + , sFeatures = (SF Nothing [] []) + , sConnectionState = XmppConnectionPlain + , sHostname = (Just hostname) + , sJid = Nothing + , sCloseConnection = (hClose con) + , sPreferredLang = Nothing -- TODO: Allow user to set + , sStreamLang = Nothing + , sStreamId = Nothing + , sToJid = Nothing -- TODO: Allow user to set + , sJidWhenPlain = False -- TODO: Allow user to set + , sFrom = Nothing + } + put st + +-- Execute a XmppConMonad computation. +xmppNewSession :: XmppConMonad a -> IO (a, XmppConnection) +xmppNewSession action = runStateT action xmppNoConnection + +-- Closes the connection and updates the XmppConMonad XmppConnection state. +xmppKillConnection :: XmppConMonad (Either Ex.SomeException ()) +xmppKillConnection = do + cc <- gets sCloseConnection + err <- liftIO $ (Ex.try cc :: IO (Either Ex.SomeException ())) + put xmppNoConnection + return err + +-- Sends an IQ request and waits for the response. If the response ID does not +-- match the outgoing ID, an error is thrown. +xmppSendIQ' :: StanzaId + -> Maybe Jid + -> IQRequestType + -> Maybe LangTag + -> Element + -> XmppConMonad (Either IQError IQResult) +xmppSendIQ' iqID to tp lang body = do + pushStanza . IQRequestS $ IQRequest iqID Nothing to lang tp body + res <- pullPickle $ xpEither xpIQError xpIQResult + case res of + Left e -> return $ Left e + Right iq' -> do + unless + (iqID == iqResultID iq') . liftIO . Ex.throwIO $ + StreamXMLError + ("In xmppSendIQ' IDs don't match: " ++ show iqID ++ " /= " ++ + show (iqResultID iq') ++ " .") + return $ Right iq' + +-- | Send "" and wait for the server to finish processing and to +-- close the connection. Any remaining elements from the server and whether or +-- not we received a element from the server is returned. +xmppCloseStreams :: XmppConMonad ([Element], Bool) +xmppCloseStreams = do + send <- gets sConPushBS + cc <- gets sCloseConnection + liftIO $ send "" + void $ liftIO $ forkIO $ do + threadDelay 3000000 + (Ex.try cc) :: IO (Either Ex.SomeException ()) + return () + collectElems [] + where + -- Pulls elements from the stream until the stream ends, or an error is + -- raised. + collectElems :: [Element] -> XmppConMonad ([Element], Bool) + collectElems elems = do + result <- Ex.try pullElement + case result of + Left StreamStreamEnd -> return (elems, True) + Left _ -> return (elems, False) + Right elem -> collectElems (elem:elems) + +debugConduit :: Pipe l ByteString ByteString u IO b +debugConduit = forever $ do + s <- await + case s of + Just s -> do + liftIO $ BS.putStrLn (BS.append "in: " s) + yield s + Nothing -> return () diff --git a/source/Network/Xmpp/Pickle.hs b/source/Network/Xmpp/Pickle.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Pickle.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +-- Marshalling between XML and Native Types + + +module Network.Xmpp.Pickle + ( mbToBool + , xmlLang + , xpLangTag + , xpNodeElem + , ignoreAttrs + , mbl + , lmb + , right + , unpickleElem' + , unpickleElem + , pickleElem + , ppElement + ) where + +import Data.XML.Types +import Data.XML.Pickle + +import Network.Xmpp.Types + +import Text.XML.Stream.Elements + +mbToBool :: Maybe t -> Bool +mbToBool (Just _) = True +mbToBool _ = False + +xmlLang :: Name +xmlLang = Name "lang" (Just "http://www.w3.org/XML/1998/namespace") (Just "xml") + +xpLangTag :: PU [Attribute] (Maybe LangTag) +xpLangTag = xpAttrImplied xmlLang xpPrim + +xpNodeElem :: PU [Node] a -> PU Element a +xpNodeElem xp = PU { pickleTree = \x -> head $ (pickleTree xp x) >>= \y -> + case y of + NodeElement e -> [e] + _ -> [] + , unpickleTree = \x -> case unpickleTree xp $ [NodeElement x] of + Left l -> Left l + Right (a,(_,c)) -> Right (a,(Nothing,c)) + } + +ignoreAttrs :: PU t ((), b) -> PU t b +ignoreAttrs = xpWrap snd ((),) + +mbl :: Maybe [a] -> [a] +mbl (Just l) = l +mbl Nothing = [] + +lmb :: [t] -> Maybe [t] +lmb [] = Nothing +lmb x = Just x + +right :: Either [Char] t -> t +right (Left l) = error l +right (Right r) = r + +unpickleElem' :: PU [Node] c -> Element -> c +unpickleElem' p x = case unpickle (xpNodeElem p) x of + Left l -> error $ (show l) ++ "\n saw: " ++ ppElement x + Right r -> r + +-- Given a pickler and an element, produces an object. +unpickleElem :: PU [Node] a -> Element -> Either UnpickleError a +unpickleElem p x = unpickle (xpNodeElem p) x + +-- Given a pickler and an object, produces an Element. +pickleElem :: PU [Node] a -> a -> Element +pickleElem p = pickle $ xpNodeElem p diff --git a/source/Network/Xmpp/Presence.hs b/source/Network/Xmpp/Presence.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Presence.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_HADDOCK hide #-} + +module Network.Xmpp.Presence where + +import Data.Text(Text) +import Network.Xmpp.Types + +-- | Add a recipient to a presence notification. +presTo :: Presence -> Jid -> Presence +presTo pres to = pres{presenceTo = Just to} diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Sasl.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} + +module Network.Xmpp.Sasl where + +import Control.Applicative +import Control.Arrow (left) +import Control.Monad +import Control.Monad.Error +import Control.Monad.State.Strict +import Data.Maybe (fromJust, isJust) + +import qualified Crypto.Classes as CC + +import qualified Data.Binary as Binary +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.Digest.Pure.MD5 as MD5 +import qualified Data.List as L +import Data.Word (Word8) + +import qualified Data.Text as Text +import Data.Text (Text) +import qualified Data.Text.Encoding as Text + +import Network.Xmpp.Monad +import Network.Xmpp.Stream +import Network.Xmpp.Types +import Network.Xmpp.Pickle + +import qualified System.Random as Random + +import Network.Xmpp.Sasl.Types + +-- Uses the first supported mechanism to authenticate, if any. Updates the +-- XmppConMonad state with non-password credentials and restarts the stream upon +-- success. This computation wraps an ErrorT computation, which means that +-- catchError can be used to catch any errors. +xmppSasl :: [SaslHandler] -- ^ Acceptable authentication mechanisms and their + -- corresponding handlers + -> XmppConMonad (Either AuthError ()) +xmppSasl handlers = do + -- Chooses the first mechanism that is acceptable by both the client and the + -- server. + mechanisms <- gets $ saslMechanisms . sFeatures + case (filter (\(name, _) -> name `elem` mechanisms)) handlers of + [] -> return . Left $ AuthNoAcceptableMechanism mechanisms + (_name, handler):_ -> runErrorT $ do + cs <- gets sConnectionState + case cs of + XmppConnectionClosed -> throwError AuthConnectionError + _ -> do + r <- handler + _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream + return r diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.Xmpp.Sasl.Common where + +import Network.Xmpp.Types + +import Control.Applicative ((<$>)) +import Control.Monad.Error +import Control.Monad.State.Class + +import qualified Data.Attoparsec.ByteString.Char8 as AP +import Data.Bits +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +import Data.Maybe (fromMaybe) +import Data.Maybe (maybeToList) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Word (Word8) +import Data.XML.Pickle +import Data.XML.Types + +import Network.Xmpp.Monad +import Network.Xmpp.Pickle +import Network.Xmpp.Sasl.Types +import Network.Xmpp.Sasl.StringPrep + +import qualified System.Random as Random + +--makeNonce :: SaslM BS.ByteString +makeNonce :: IO BS.ByteString +makeNonce = do + g <- liftIO Random.newStdGen + return $ B64.encode . BS.pack . map toWord8 . take 15 $ Random.randoms g + where + toWord8 :: Int -> Word8 + toWord8 x = fromIntegral x :: Word8 + +-- The element, with an +-- optional round-trip value. +saslInitE :: Text.Text -> Maybe Text.Text -> Element +saslInitE mechanism rt = + Element "{urn:ietf:params:xml:ns:xmpp-sasl}auth" + [("mechanism", [ContentText mechanism])] + (maybeToList $ NodeContent . ContentText <$> rt) + +-- SASL response with text payload. +saslResponseE :: Maybe Text.Text -> Element +saslResponseE resp = + Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" + [] + (maybeToList $ NodeContent . ContentText <$> resp) + +-- The element. +xpSuccess :: PU [Node] (Maybe Text.Text) +xpSuccess = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}success" + (xpOption $ xpContent xpId) + +-- Parses the incoming SASL data to a mapped list of pairs. +pairs :: BS.ByteString -> Either String Pairs +pairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do + AP.skipSpace + name <- AP.takeWhile1 (/= '=') + _ <- AP.char '=' + quote <- ((AP.char '"' >> return True) `mplus` return False) + content <- AP.takeWhile1 (AP.notInClass [',', '"']) + when quote . void $ AP.char '"' + return (name, content) + +-- Failure element pickler. +xpFailure :: PU [Node] SaslFailure +xpFailure = xpWrap + (\(txt, (failure, _, _)) -> SaslFailure failure txt) + (\(SaslFailure failure txt) -> (txt,(failure,(),()))) + (xpElemNodes + "{urn:ietf:params:xml:ns:xmpp-sasl}failure" + (xp2Tuple + (xpOption $ xpElem + "{urn:ietf:params:xml:ns:xmpp-sasl}text" + xpLangTag + (xpContent xpId)) + (xpElemByNamespace + "urn:ietf:params:xml:ns:xmpp-sasl" + xpPrim + (xpUnit) + (xpUnit)))) + +-- Challenge element pickler. +xpChallenge :: PU [Node] (Maybe Text.Text) +xpChallenge = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" + (xpOption $ xpContent xpId) + +-- | Pickler for SaslElement. +xpSaslElement :: PU [Node] SaslElement +xpSaslElement = xpAlt saslSel + [ xpWrap SaslSuccess (\(SaslSuccess x) -> x) xpSuccess + , xpWrap SaslChallenge (\(SaslChallenge c) -> c) xpChallenge + ] + where + saslSel (SaslSuccess _) = 0 + saslSel (SaslChallenge _) = 1 + +-- | Add quotationmarks around a byte string. +quote :: BS.ByteString -> BS.ByteString +quote x = BS.concat ["\"",x,"\""] + +saslInit :: Text.Text -> Maybe BS.ByteString -> SaslM Bool +saslInit mechanism payload = lift . pushElement . saslInitE mechanism $ + Text.decodeUtf8 . B64.encode <$> payload + +-- | Pull the next element. +pullSaslElement :: SaslM SaslElement +pullSaslElement = do + el <- lift $ pullPickle (xpEither xpFailure xpSaslElement) + case el of + Left e ->throwError $ AuthSaslFailure e + Right r -> return r + +-- | Pull the next element, checking that it is a challenge. +pullChallenge :: SaslM (Maybe BS.ByteString) +pullChallenge = do + e <- pullSaslElement + case e of + SaslChallenge Nothing -> return Nothing + SaslChallenge (Just scb64) + | Right sc <- B64.decode . Text.encodeUtf8 $ scb64 + -> return $ Just sc + _ -> throwError AuthChallengeError + +-- | Extract value from Just, failing with AuthChallengeError on Nothing. +saslFromJust :: Maybe a -> SaslM a +saslFromJust Nothing = throwError $ AuthChallengeError +saslFromJust (Just d) = return d + +-- | Pull the next element and check that it is success. +pullSuccess :: SaslM (Maybe Text.Text) +pullSuccess = do + e <- pullSaslElement + case e of + SaslSuccess x -> return x + _ -> throwError $ AuthXmlError + +-- | Pull the next element. When it's success, return it's payload. +-- If it's a challenge, send an empty response and pull success. +pullFinalMessage :: SaslM (Maybe BS.ByteString) +pullFinalMessage = do + challenge2 <- pullSaslElement + case challenge2 of + SaslSuccess x -> decode x + SaslChallenge x -> do + _b <- respond Nothing + _s <- pullSuccess + decode x + where + decode Nothing = return Nothing + decode (Just d) = case B64.decode $ Text.encodeUtf8 d of + Left _e -> throwError $ AuthChallengeError + Right x -> return $ Just x + +-- | Extract p=q pairs from a challenge. +toPairs :: BS.ByteString -> SaslM Pairs +toPairs ctext = case pairs ctext of + Left _e -> throwError AuthChallengeError + Right r -> return r + +-- | Send a SASL response element. The content will be base64-encoded. +respond :: Maybe BS.ByteString -> SaslM Bool +respond = lift . pushElement . saslResponseE . + fmap (Text.decodeUtf8 . B64.encode) + + +-- | Run the appropriate stringprep profiles on the credentials. +-- May fail with 'AuthStringPrepError' +prepCredentials :: Text.Text -> Maybe Text.Text -> Text.Text + -> SaslM (Text.Text, Maybe Text.Text, Text.Text) +prepCredentials authcid authzid password = case credentials of + Nothing -> throwError $ AuthStringPrepError + Just creds -> return creds + where + credentials = do + ac <- normalizeUsername authcid + az <- case authzid of + Nothing -> Just Nothing + Just az' -> Just <$> normalizeUsername az' + pw <- normalizePassword password + return (ac, az, pw) + +-- | Bit-wise xor of byte strings +xorBS :: BS.ByteString -> BS.ByteString -> BS.ByteString +xorBS x y = BS.pack $ BS.zipWith xor x y + +-- | Join byte strings with "," +merge :: [BS.ByteString] -> BS.ByteString +merge = BS.intercalate "," + +-- | Infix concatenation of byte strings +(+++) :: BS.ByteString -> BS.ByteString -> BS.ByteString +(+++) = BS.append diff --git a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.Xmpp.Sasl.Mechanisms.DigestMd5 where + +import Control.Applicative +import Control.Arrow (left) +import Control.Monad +import Control.Monad.Error +import Control.Monad.State.Strict +import Data.Maybe (fromJust, isJust) + +import qualified Crypto.Classes as CC + +import qualified Data.Binary as Binary +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.Digest.Pure.MD5 as MD5 +import qualified Data.List as L + +import qualified Data.Text as Text +import Data.Text (Text) +import qualified Data.Text.Encoding as Text + +import Data.XML.Pickle + +import qualified Data.ByteString as BS + +import Data.XML.Types + +import Network.Xmpp.Monad +import Network.Xmpp.Pickle +import Network.Xmpp.Stream +import Network.Xmpp.Types + + +import Network.Xmpp.Sasl.Common +import Network.Xmpp.Sasl.StringPrep +import Network.Xmpp.Sasl.Types + + + +xmppDigestMd5 :: Text -- Authorization identity (authzid) + -> Maybe Text -- Authentication identity (authzid) + -> Text -- Password (authzid) + -> SaslM () +xmppDigestMd5 authcid authzid password = do + (ac, az, pw) <- prepCredentials authcid authzid password + hn <- gets sHostname + case hn of + Just hn' -> do + xmppDigestMd5' hn' ac az pw + Nothing -> throwError AuthConnectionError + where + xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> SaslM () + xmppDigestMd5' hostname authcid authzid password = do + -- Push element and receive the challenge (in SaslM). + _ <- saslInit "DIGEST-MD5" Nothing -- TODO: Check boolean? + pairs <- toPairs =<< saslFromJust =<< pullChallenge + cnonce <- liftIO $ makeNonce + _b <- respond . Just $ createResponse hostname pairs cnonce + challenge2 <- pullFinalMessage + _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream + return () + where + -- Produce the response to the challenge. + createResponse :: Text + -> Pairs + -> BS.ByteString -- nonce + -> BS.ByteString + createResponse hostname pairs cnonce = let + Just qop = L.lookup "qop" pairs -- TODO: proper handling + Just nonce = L.lookup "nonce" pairs + uname_ = Text.encodeUtf8 authcid + passwd_ = Text.encodeUtf8 password + -- Using Int instead of Word8 for random 1.0.0.0 (GHC 7) + -- compatibility. + + nc = "00000001" + digestURI = "xmpp/" `BS.append` Text.encodeUtf8 hostname + digest = md5Digest + uname_ + (lookup "realm" pairs) + passwd_ + digestURI + nc + qop + nonce + cnonce + response = BS.intercalate "," . map (BS.intercalate "=") $ + [["username", quote uname_]] ++ + case L.lookup "realm" pairs of + Just realm -> [["realm" , quote realm ]] + Nothing -> [] ++ + [ ["nonce" , quote nonce ] + , ["cnonce" , quote cnonce ] + , ["nc" , nc ] + , ["qop" , qop ] + , ["digest-uri", quote digestURI] + , ["response" , digest ] + , ["charset" , "utf-8" ] + ] + in B64.encode response + hash :: [BS8.ByteString] -> BS8.ByteString + hash = BS8.pack . show + . (CC.hash' :: BS.ByteString -> MD5.MD5Digest) + . BS.intercalate (":") + hashRaw :: [BS8.ByteString] -> BS8.ByteString + hashRaw = toStrict . Binary.encode . + (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":") + toStrict :: BL.ByteString -> BS8.ByteString + toStrict = BS.concat . BL.toChunks + -- TODO: this only handles MD5-sess + md5Digest :: BS8.ByteString + -> Maybe BS8.ByteString + -> BS8.ByteString + -> BS8.ByteString + -> BS8.ByteString + -> BS8.ByteString + -> BS8.ByteString + -> BS8.ByteString + -> BS8.ByteString + md5Digest uname realm password digestURI nc qop nonce cnonce = + let ha1 = hash [ hashRaw [uname, maybe "" id realm, password] + , nonce + , cnonce + ] + ha2 = hash ["AUTHENTICATE", digestURI] + in hash [ha1, nonce, nc, cnonce, qop, ha2] + +digestMd5 :: Text -- Authorization identity (authzid) + -> Maybe Text -- Authentication identity (authzid) + -> Text -- Password (authzid) + -> SaslHandler +digestMd5 authcid authzid password = ( "DIGEST-MD5" + , xmppDigestMd5 authcid authzid password + ) diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs @@ -0,0 +1,76 @@ +-- Implementation of the PLAIN Simple Authentication and Security Layer (SASL) +-- Mechanism, http://tools.ietf.org/html/rfc4616. + +{-# LANGUAGE OverloadedStrings #-} + +module Network.Xmpp.Sasl.Mechanisms.Plain where + +import Control.Applicative +import Control.Arrow (left) +import Control.Monad +import Control.Monad.Error +import Control.Monad.State.Strict +import Data.Maybe (fromJust, isJust) + +import qualified Crypto.Classes as CC + +import qualified Data.Binary as Binary +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.Digest.Pure.MD5 as MD5 +import qualified Data.List as L +import Data.Word (Word8) + +import qualified Data.Text as Text +import Data.Text (Text) +import qualified Data.Text.Encoding as Text + +import Data.XML.Pickle + +import qualified Data.ByteString as BS + +import Data.XML.Types + +import Network.Xmpp.Monad +import Network.Xmpp.Stream +import Network.Xmpp.Types +import Network.Xmpp.Pickle + +import qualified System.Random as Random + +import Data.Maybe (fromMaybe) +import qualified Data.Text as Text + +import Network.Xmpp.Sasl.Common +import Network.Xmpp.Sasl.Types + +-- TODO: stringprep +xmppPlain :: Text.Text -- ^ Password + -> Maybe Text.Text -- ^ Authorization identity (authzid) + -> Text.Text -- ^ Authentication identity (authcid) + -> SaslM () +xmppPlain authcid authzid password = do + (ac, az, pw) <- prepCredentials authcid authzid password + _ <- saslInit "PLAIN" ( Just $ plainMessage ac az pw) + _ <- pullSuccess + return () + where + -- Converts an optional authorization identity, an authentication identity, + -- and a password to a \NUL-separated PLAIN message. + plainMessage :: Text.Text -- Authorization identity (authzid) + -> Maybe Text.Text -- Authentication identity (authcid) + -> Text.Text -- Password + -> BS.ByteString -- The PLAIN message + plainMessage authcid authzid passwd = BS.concat $ + [ authzid' + , "\NUL" + , Text.encodeUtf8 $ authcid + , "\NUL" + , Text.encodeUtf8 $ passwd + ] + where + authzid' = maybe "" Text.encodeUtf8 authzid + +plain :: Text.Text -> Maybe Text.Text -> Text.Text -> SaslHandler +plain authcid authzid passwd = ("PLAIN", xmppPlain authcid authzid passwd) diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.Xmpp.Sasl.Mechanisms.Scram where + +import Control.Applicative ((<$>)) +import Control.Monad.Error +import Control.Monad.Trans (liftIO) +import qualified Crypto.Classes as Crypto +import qualified Crypto.HMAC as Crypto +import qualified Crypto.Hash.SHA1 as Crypto +import Data.Binary(Binary,encode) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +import Data.ByteString.Char8 as BS8 (unpack) +import qualified Data.ByteString.Lazy as LBS +import Data.List (foldl1', genericTake) + +import qualified Data.Binary.Builder as Build + +import Data.Maybe (maybeToList) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Word(Word8) + +import Network.Xmpp.Sasl.Common +import Network.Xmpp.Sasl.StringPrep +import Network.Xmpp.Sasl.Types + +-- | A nicer name for undefined, for use as a dummy token to determin +-- the hash function to use +hashToken :: (Crypto.Hash ctx hash) => hash +hashToken = undefined + +-- | Salted Challenge Response Authentication Mechanism (SCRAM) SASL +-- mechanism according to RFC 5802. +-- +-- This implementation is independent and polymorphic in the used hash function. +scram :: (Crypto.Hash ctx hash) + => hash -- ^ Dummy argument to determine the hash to use; you + -- can safely pass undefined or a 'hashToken' to it + -> Text.Text -- ^ Authentication ID (user name) + -> Maybe Text.Text -- ^ Authorization ID + -> Text.Text -- ^ Password + -> SaslM () +scram hashToken authcid authzid password = do + (ac, az, pw) <- prepCredentials authcid authzid password + scramhelper hashToken ac az pw + where + scramhelper hashToken authcid authzid' password = do + cnonce <- liftIO $ makeNonce + saslInit "SCRAM-SHA-1" (Just $ cFirstMessage cnonce) + sFirstMessage <- saslFromJust =<< pullChallenge + pairs <- toPairs sFirstMessage + (nonce, salt, ic) <- fromPairs pairs cnonce + let (cfm, v) = cFinalMessageAndVerifier nonce salt ic sFirstMessage cnonce + respond $ Just cfm + finalPairs <- toPairs =<< saslFromJust =<< pullFinalMessage + unless (lookup "v" finalPairs == Just v) $ throwError AuthServerAuthError + return () + where + -- We need to jump through some hoops to get a polymorphic solution + encode :: Crypto.Hash ctx hash => hash -> hash -> BS.ByteString + encode _hashtoken = Crypto.encode + + hash :: BS.ByteString -> BS.ByteString + hash str = encode hashToken $ Crypto.hash' str + + hmac :: BS.ByteString -> BS.ByteString -> BS.ByteString + hmac key str = encode hashToken $ Crypto.hmac' (Crypto.MacKey key) str + + authzid :: Maybe BS.ByteString + authzid = (\z -> "a=" +++ Text.encodeUtf8 z) <$> authzid' + + gs2CbindFlag :: BS.ByteString + gs2CbindFlag = "n" -- we don't support channel binding yet + + gs2Header :: BS.ByteString + gs2Header = merge $ [ gs2CbindFlag + , maybe "" id authzid + , "" + ] + cbindData :: BS.ByteString + cbindData = "" -- we don't support channel binding yet + + cFirstMessageBare :: BS.ByteString -> BS.ByteString + cFirstMessageBare cnonce = merge [ "n=" +++ Text.encodeUtf8 authcid + , "r=" +++ cnonce] + cFirstMessage :: BS.ByteString -> BS.ByteString + cFirstMessage cnonce = gs2Header +++ cFirstMessageBare cnonce + + fromPairs :: Pairs + -> BS.ByteString + -> SaslM (BS.ByteString, BS.ByteString, Integer) + fromPairs pairs cnonce | Just nonce <- lookup "r" pairs + , cnonce `BS.isPrefixOf` nonce + , Just salt' <- lookup "s" pairs + , Right salt <- B64.decode salt' + , Just ic <- lookup "i" pairs + , [(i,"")] <- reads $ BS8.unpack ic + = return (nonce, salt, i) + fromPairs _ _ = throwError $ AuthChallengeError + + cFinalMessageAndVerifier :: BS.ByteString + -> BS.ByteString + -> Integer + -> BS.ByteString + -> BS.ByteString + -> (BS.ByteString, BS.ByteString) + cFinalMessageAndVerifier nonce salt ic sfm cnonce + = (merge [ cFinalMessageWOProof + , "p=" +++ B64.encode clientProof + ] + , B64.encode serverSignature + ) + where + cFinalMessageWOProof :: BS.ByteString + cFinalMessageWOProof = merge [ "c=" +++ B64.encode gs2Header + , "r=" +++ nonce] + + saltedPassword :: BS.ByteString + saltedPassword = hi (Text.encodeUtf8 password) salt ic + + clientKey :: BS.ByteString + clientKey = hmac saltedPassword "Client Key" + + storedKey :: BS.ByteString + storedKey = hash clientKey + + authMessage :: BS.ByteString + authMessage = merge [ cFirstMessageBare cnonce + , sfm + , cFinalMessageWOProof + ] + + clientSignature :: BS.ByteString + clientSignature = hmac storedKey authMessage + + clientProof :: BS.ByteString + clientProof = clientKey `xorBS` clientSignature + + serverKey :: BS.ByteString + serverKey = hmac saltedPassword "Server Key" + + serverSignature :: BS.ByteString + serverSignature = hmac serverKey authMessage + + -- helper + hi :: BS.ByteString -> BS.ByteString -> Integer -> BS.ByteString + hi str salt ic = foldl1' xorBS (genericTake ic us) + where + u1 = hmac str (salt +++ (BS.pack [0,0,0,1])) + us = iterate (hmac str) u1 + +-- | 'scram' spezialised to the SHA-1 hash function, packaged as a SaslHandler +scramSha1 :: Text.Text -- ^ username + -> Maybe Text.Text -- ^ authorization ID + -> Text.Text -- ^ password + -> SaslHandler +scramSha1 authcid authzid passwd = + ("SCRAM-SHA-1" + , scram (hashToken :: Crypto.SHA1) authcid authzid passwd + ) diff --git a/source/Network/Xmpp/Sasl/StringPrep.hs b/source/Network/Xmpp/Sasl/StringPrep.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Sasl/StringPrep.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.Xmpp.Sasl.StringPrep where + +import Text.StringPrep +import qualified Data.Set as Set +import Data.Text(singleton) + +nonAsciiSpaces = Set.fromList [ '\x00A0', '\x1680', '\x2000', '\x2001', '\x2002' + , '\x2003', '\x2004', '\x2005', '\x2006', '\x2007' + , '\x2008', '\x2009', '\x200A', '\x200B', '\x202F' + , '\x205F', '\x3000' + ] + +toSpace x = if x `Set.member` nonAsciiSpaces then " " else singleton x + +saslPrepQuery = Profile + [b1, toSpace] + True + [c12, c21, c22, c3, c4, c5, c6, c7, c8, c9] + True + +saslPrepStore = Profile + [b1, toSpace] + True + [a1, c12, c21, c22, c3, c4, c5, c6, c7, c8, c9] + True + +normalizePassword = runStringPrep saslPrepStore +normalizeUsername = runStringPrep saslPrepQuery diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Sasl/Types.hs @@ -0,0 +1,36 @@ +module Network.Xmpp.Sasl.Types where + +import Control.Monad.Error +import Control.Monad.State.Strict +import Data.ByteString(ByteString) +import qualified Data.Text as Text +import Network.Xmpp.Types + +data AuthError = AuthXmlError + | AuthNoAcceptableMechanism [Text.Text] -- ^ Wraps mechanisms + -- offered + | AuthChallengeError + | AuthServerAuthError -- ^ The server failed to authenticate + -- itself + | AuthStreamError StreamError -- ^ Stream error on stream restart + -- TODO: Rename AuthConnectionError? + | AuthConnectionError -- ^ Connection is closed + | AuthError -- General instance used for the Error instance + | AuthSaslFailure SaslFailure -- ^ Defined SASL error condition + | AuthStringPrepError -- ^ StringPrep failed + deriving Show + +instance Error AuthError where + noMsg = AuthError + +data SaslElement = SaslSuccess (Maybe Text.Text) + | SaslChallenge (Maybe Text.Text) + +-- | SASL mechanism XmppConnection computation, with the possibility of throwing +-- an authentication error. +type SaslM a = ErrorT AuthError (StateT XmppConnection IO) a + +type Pairs = [(ByteString, ByteString)] + +-- | Tuple defining the SASL Handler's name, and a SASL mechanism computation +type SaslHandler = (Text.Text, SaslM ()) diff --git a/source/Network/Xmpp/Session.hs b/source/Network/Xmpp/Session.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Session.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.Xmpp.Session where + +import Data.XML.Pickle +import Data.XML.Types(Element) + +import Network.Xmpp.Monad +import Network.Xmpp.Pickle +import Network.Xmpp.Types +import Network.Xmpp.Concurrent + +sessionXML :: Element +sessionXML = pickleElem + (xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session") + () + +sessionIQ :: Stanza +sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess" + , iqRequestFrom = Nothing + , iqRequestTo = Nothing + , iqRequestLangTag = Nothing + , iqRequestType = Set + , iqRequestPayload = sessionXML + } + +-- Sends the session IQ set element and waits for an answer. Throws an error if +-- if an IQ error stanza is returned from the server. +xmppStartSession :: XmppConMonad () +xmppStartSession = do + answer <- xmppSendIQ' "session" Nothing Set Nothing sessionXML + case answer of + Left e -> error $ show e + Right _ -> return () + +-- Sends the session IQ set element and waits for an answer. Throws an error if +-- if an IQ error stanza is returned from the server. +startSession :: Session -> IO () +startSession session = do + answer <- sendIQ' Nothing Set Nothing sessionXML session + case answer of + IQResponseResult _ -> return () + e -> error $ show e diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Stream.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Network.Xmpp.Stream where + +import Control.Applicative ((<$>), (<*>)) +import qualified Control.Exception as Ex +import Control.Monad.Error +import Control.Monad.State.Strict + +import Data.Conduit +import Data.Conduit.BufferedSource +import Data.Conduit.List as CL +import Data.Maybe (fromJust, isJust, isNothing) +import Data.Text as Text +import Data.XML.Pickle +import Data.XML.Types +import Data.Void (Void) + +import Network.Xmpp.Monad +import Network.Xmpp.Pickle +import Network.Xmpp.Types +import Network.Xmpp.Errors + +import Text.XML.Stream.Elements +import Text.XML.Stream.Parse as XP + +-- import Text.XML.Stream.Elements + +-- Unpickles and returns a stream element. Throws a StreamXMLError on failure. +streamUnpickleElem :: PU [Node] a + -> Element + -> StreamSink a +streamUnpickleElem p x = do + case unpickleElem p x of + Left l -> throwError $ StreamXMLError (show l) + Right r -> return r + +-- This is the conduit sink that handles the stream XML events. We extend it +-- with ErrorT capabilities. +type StreamSink a = ErrorT StreamError (Pipe Event Event Void () IO) a + +-- Discards all events before the first EventBeginElement. +throwOutJunk :: Monad m => Sink Event m () +throwOutJunk = do + next <- CL.peek + case next of + Nothing -> return () -- This will only happen if the stream is closed. + Just (EventBeginElement _ _) -> return () + _ -> CL.drop 1 >> throwOutJunk + +-- Returns an (empty) Element from a stream of XML events. +openElementFromEvents :: StreamSink Element +openElementFromEvents = do + lift throwOutJunk + hd <- lift CL.head + case hd of + Just (EventBeginElement name attrs) -> return $ Element name attrs [] + _ -> throwError $ StreamConnectionError + +-- Sends the initial stream:stream element and pulls the server features. +xmppStartStream :: XmppConMonad (Either StreamError ()) +xmppStartStream = runErrorT $ do + state <- get + -- Set the `to' attribute depending on the state of the connection. + let from = case sConnectionState state of + XmppConnectionPlain -> if sJidWhenPlain state + then sJid state else Nothing + XmppConnectionSecured -> sJid state + case sHostname state of + Nothing -> throwError StreamConnectionError + Just hostname -> lift $ do + pushXmlDecl + pushOpenElement $ + pickleElem xpStream ( "1.0" + , from + , Just (Jid Nothing hostname Nothing) + , Nothing + , sPreferredLang state + ) + (lt, from, id, features) <- ErrorT . pullToSink $ runErrorT $ xmppStream from + modify (\s -> s { sFeatures = features + , sStreamLang = Just lt + , sStreamId = id + , sFrom = from + } + ) + return () + +-- Sets a new Event source using the raw source (of bytes) +-- and calls xmppStartStream. +xmppRestartStream :: XmppConMonad (Either StreamError ()) +xmppRestartStream = do + raw <- gets sRawSrc + newsrc <- liftIO . bufferSource $ raw $= XP.parseBytes def + modify (\s -> s{sConSrc = newsrc}) + xmppStartStream + +-- Reads the (partial) stream:stream and the server features from the stream. +-- Also validates the stream element's attributes and throws an error if +-- appropriate. +-- TODO: from. +xmppStream :: Maybe Jid -> StreamSink ( LangTag + , Maybe Jid + , Maybe Text + , ServerFeatures) +xmppStream expectedTo = do + (from, to, id, langTag) <- xmppStreamHeader + features <- xmppStreamFeatures + return (langTag, from, id, features) + where + xmppStreamHeader :: StreamSink (Maybe Jid, Maybe Jid, Maybe Text.Text, LangTag) + xmppStreamHeader = do + lift throwOutJunk + -- Get the stream:stream element (or whatever it is) from the server, + -- and validate what we get. + el <- openElementFromEvents + case unpickleElem xpStream el of + Left _ -> throwError $ findStreamErrors el + Right r -> validateData r + + validateData (_, _, _, _, Nothing) = throwError $ StreamWrongLangTag Nothing + validateData (ver, from, to, i, Just lang) + | ver /= "1.0" = throwError $ StreamWrongVersion (Just ver) + | isJust to && to /= expectedTo = throwError $ StreamWrongTo (Text.pack . show <$> to) + | otherwise = return (from, to, i, lang) + xmppStreamFeatures :: StreamSink ServerFeatures + xmppStreamFeatures = do + e <- lift $ elements =$ CL.head + case e of + Nothing -> liftIO $ Ex.throwIO StreamConnectionError + Just r -> streamUnpickleElem xpStreamFeatures r + + + +xpStream :: PU [Node] (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag) +xpStream = xpElemAttrs + (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) + (xp5Tuple + (xpAttr "version" xpId) + (xpAttrImplied "from" xpPrim) + (xpAttrImplied "to" xpPrim) + (xpAttrImplied "id" xpId) + xpLangTag + ) + +-- Pickler/Unpickler for the stream features - TLS, SASL, and the rest. +xpStreamFeatures :: PU [Node] ServerFeatures +xpStreamFeatures = xpWrap + (\(tls, sasl, rest) -> SF tls (mbl sasl) rest) + (\(SF tls sasl rest) -> (tls, lmb sasl, rest)) + (xpElemNodes + (Name + "features" + (Just "http://etherx.jabber.org/streams") + (Just "stream") + ) + (xpTriple + (xpOption pickleTLSFeature) + (xpOption pickleSaslFeature) + (xpAll xpElemVerbatim) + ) + ) + where + pickleTLSFeature :: PU [Node] Bool + pickleTLSFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls" + (xpElemExists "required") + pickleSaslFeature :: PU [Node] [Text] + pickleSaslFeature = xpElemNodes + "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms" + (xpAll $ xpElemNodes + "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" (xpContent xpId)) diff --git a/source/Network/Xmpp/TLS.hs b/source/Network/Xmpp/TLS.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/TLS.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.Xmpp.TLS where + +import qualified Control.Exception.Lifted as Ex +import Control.Monad +import Control.Monad.Error +import Control.Monad.State.Strict + +import Data.Conduit.TLS as TLS +import Data.Typeable +import Data.XML.Types + +import Network.Xmpp.Monad +import Network.Xmpp.Pickle(ppElement) +import Network.Xmpp.Stream +import Network.Xmpp.Types + +starttlsE :: Element +starttlsE = Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] [] + +exampleParams :: TLS.TLSParams +exampleParams = TLS.defaultParamsClient + { pConnectVersion = TLS.TLS10 + , pAllowedVersions = [TLS.SSL3, TLS.TLS10, TLS.TLS11] + , pCiphers = [TLS.cipher_AES128_SHA1] + , pCompressions = [TLS.nullCompression] + , pUseSecureRenegotiation = False -- No renegotiation + , onCertificatesRecv = \_certificate -> + return TLS.CertificateUsageAccept + } + +-- | Error conditions that may arise during TLS negotiation. +data XmppTLSError = TLSError TLSError + | TLSNoServerSupport + | TLSNoConnection + | TLSStreamError StreamError + | XmppTLSError -- General instance used for the Error instance + deriving (Show, Eq, Typeable) + +instance Error XmppTLSError where + noMsg = XmppTLSError + +-- Pushes ", waits for "", performs the TLS handshake, and +-- restarts the stream. May throw errors. +startTLS :: TLS.TLSParams -> XmppConMonad (Either XmppTLSError ()) +startTLS params = Ex.handle (return . Left . TLSError) . runErrorT $ do + features <- lift $ gets sFeatures + handle' <- lift $ gets sConHandle + handle <- maybe (throwError TLSNoConnection) return handle' + when (stls features == Nothing) $ throwError TLSNoServerSupport + lift $ pushElement starttlsE + answer <- lift $ pullElement + case answer of + Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] -> return () + Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _ -> + lift . Ex.throwIO $ StreamConnectionError + -- TODO: find something more suitable + e -> lift . Ex.throwIO . StreamXMLError $ + "Unexpected element: " ++ ppElement e + (raw, _snk, psh, ctx) <- lift $ TLS.tlsinit debug params handle + lift $ modify ( \x -> x + { sRawSrc = raw +-- , sConSrc = -- Note: this momentarily leaves us in an + -- inconsistent state + , sConPushBS = catchPush . psh + , sCloseConnection = TLS.bye ctx >> sCloseConnection x + }) + either (lift . Ex.throwIO) return =<< lift xmppRestartStream + modify (\s -> s{sConnectionState = XmppConnectionSecured}) + return () diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Types.hs @@ -0,0 +1,783 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_HADDOCK hide #-} + +module Network.Xmpp.Types + ( IQError(..) + , IQRequest(..) + , IQRequestType(..) + , IQResponse(..) + , IQResult(..) + , IdGenerator(..) + , LangTag (..) + , Message(..) + , MessageError(..) + , MessageType(..) + , Presence(..) + , PresenceError(..) + , PresenceType(..) + , SaslError(..) + , SaslFailure(..) + , ServerFeatures(..) + , Stanza(..) + , StanzaError(..) + , StanzaErrorCondition(..) + , StanzaErrorType(..) + , StanzaId(..) + , StreamError(..) + , StreamErrorCondition(..) + , Version(..) + , XmppConMonad + , XmppConnection(..) + , XmppConnectionState(..) + , XmppT(..) + , XmppStreamError(..) + , langTag + , module Network.Xmpp.Jid + ) + where + +import Control.Applicative ((<$>), many) +import Control.Exception +import Control.Monad.IO.Class +import Control.Monad.State.Strict +import Control.Monad.Error + +import qualified Data.Attoparsec.Text as AP +import qualified Data.ByteString as BS +import Data.Conduit +import Data.String(IsString(..)) +import Data.Maybe (fromJust, fromMaybe, maybeToList) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Typeable(Typeable) +import Data.XML.Types + +import qualified Network as N + +import Network.Xmpp.Jid + +import System.IO + +-- | +-- Wraps a string of random characters that, when using an appropriate +-- @IDGenerator@, is guaranteed to be unique for the Xmpp session. + +data StanzaId = SI !Text deriving (Eq, Ord) + +instance Show StanzaId where + show (SI s) = Text.unpack s + +instance Read StanzaId where + readsPrec _ x = [(SI $ Text.pack x, "")] + +instance IsString StanzaId where + fromString = SI . Text.pack + +-- | The Xmpp communication primities (Message, Presence and Info/Query) are +-- called stanzas. +data Stanza = IQRequestS !IQRequest + | IQResultS !IQResult + | IQErrorS !IQError + | MessageS !Message + | MessageErrorS !MessageError + | PresenceS !Presence + | PresenceErrorS !PresenceError + deriving Show + +-- | A "request" Info/Query (IQ) stanza is one with either "get" or "set" as +-- type. It always contains an xml payload. +data IQRequest = IQRequest { iqRequestID :: !StanzaId + , iqRequestFrom :: !(Maybe Jid) + , iqRequestTo :: !(Maybe Jid) + , iqRequestLangTag :: !(Maybe LangTag) + , iqRequestType :: !IQRequestType + , iqRequestPayload :: !Element + } deriving Show + +-- | The type of IQ request that is made. +data IQRequestType = Get | Set deriving (Eq, Ord) + +instance Show IQRequestType where + show Get = "get" + show Set = "set" + +instance Read IQRequestType where + readsPrec _ "get" = [(Get, "")] + readsPrec _ "set" = [(Set, "")] + readsPrec _ _ = [] + +-- | A "response" Info/Query (IQ) stanza is either an 'IQError', an IQ stanza +-- of type "result" ('IQResult') or a Timeout. +data IQResponse = IQResponseError IQError + | IQResponseResult IQResult + | IQResponseTimeout + deriving Show + +-- | The (non-error) answer to an IQ request. +data IQResult = IQResult { iqResultID :: !StanzaId + , iqResultFrom :: !(Maybe Jid) + , iqResultTo :: !(Maybe Jid) + , iqResultLangTag :: !(Maybe LangTag) + , iqResultPayload :: !(Maybe Element) + } deriving Show + +-- | The answer to an IQ request that generated an error. +data IQError = IQError { iqErrorID :: !StanzaId + , iqErrorFrom :: !(Maybe Jid) + , iqErrorTo :: !(Maybe Jid) + , iqErrorLangTag :: !(Maybe LangTag) + , iqErrorStanzaError :: !StanzaError + , iqErrorPayload :: !(Maybe Element) -- should this be []? + } deriving Show + +-- | The message stanza. Used for /push/ type communication. +data Message = Message { messageID :: !(Maybe StanzaId) + , messageFrom :: !(Maybe Jid) + , messageTo :: !(Maybe Jid) + , messageLangTag :: !(Maybe LangTag) + , messageType :: !MessageType + , messagePayload :: ![Element] + } deriving Show + +-- | An error stanza generated in response to a 'Message'. +data MessageError = MessageError { messageErrorID :: !(Maybe StanzaId) + , messageErrorFrom :: !(Maybe Jid) + , messageErrorTo :: !(Maybe Jid) + , messageErrorLangTag :: !(Maybe LangTag) + , messageErrorStanzaError :: !StanzaError + , messageErrorPayload :: ![Element] + } deriving (Show) + + +-- | The type of a Message being sent +-- () +data MessageType = -- | The message is sent in the context of a one-to-one chat + -- session. Typically an interactive client will present a + -- message of type /chat/ in an interface that enables + -- one-to-one chat between the two parties, including an + -- appropriate conversation history. + Chat + -- | The message is sent in the context of a multi-user chat + -- environment (similar to that of @IRC@). Typically a + -- receiving client will present a message of type + -- /groupchat/ in an interface that enables many-to-many + -- chat between the parties, including a roster of parties + -- in the chatroom and an appropriate conversation history. + | GroupChat + -- | The message provides an alert, a notification, or other + -- transient information to which no reply is expected + -- (e.g., news headlines, sports updates, near-real-time + -- market data, or syndicated content). Because no reply to + -- the message is expected, typically a receiving client + -- will present a message of type /headline/ in an interface + -- that appropriately differentiates the message from + -- standalone messages, chat messages, and groupchat + -- messages (e.g., by not providing the recipient with the + -- ability to reply). + | Headline + -- | The message is a standalone message that is sent outside + -- the context of a one-to-one conversation or groupchat, and + -- to which it is expected that the recipient will reply. + -- Typically a receiving client will present a message of + -- type /normal/ in an interface that enables the recipient + -- to reply, but without a conversation history. + -- + -- This is the /default/ value. + | Normal + deriving (Eq) + +instance Show MessageType where + show Chat = "chat" + show GroupChat = "groupchat" + show Headline = "headline" + show Normal = "normal" + +instance Read MessageType where + readsPrec _ "chat" = [(Chat, "")] + readsPrec _ "groupchat" = [(GroupChat, "")] + readsPrec _ "headline" = [(Headline, "")] + readsPrec _ "normal" = [(Normal, "")] + readsPrec _ _ = [(Normal, "")] + +-- | The presence stanza. Used for communicating status updates. +data Presence = Presence { presenceID :: !(Maybe StanzaId) + , presenceFrom :: !(Maybe Jid) + , presenceTo :: !(Maybe Jid) + , presenceLangTag :: !(Maybe LangTag) + , presenceType :: !(Maybe PresenceType) + , presencePayload :: ![Element] + } deriving Show + + +-- | An error stanza generated in response to a 'Presence'. +data PresenceError = PresenceError { presenceErrorID :: !(Maybe StanzaId) + , presenceErrorFrom :: !(Maybe Jid) + , presenceErrorTo :: !(Maybe Jid) + , presenceErrorLangTag :: !(Maybe LangTag) + , presenceErrorStanzaError :: !StanzaError + , presenceErrorPayload :: ![Element] + } deriving Show + +-- | @PresenceType@ holds Xmpp presence types. The "error" message type is left +-- out as errors are using @PresenceError@. +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 + Default | + Unavailable deriving (Eq) + +instance Show PresenceType where + show Subscribe = "subscribe" + show Subscribed = "subscribed" + show Unsubscribe = "unsubscribe" + show Unsubscribed = "unsubscribed" + show Probe = "probe" + show Default = "" + show Unavailable = "unavailable" + +instance Read PresenceType where + readsPrec _ "" = [(Default, "")] + readsPrec _ "available" = [(Default, "")] + readsPrec _ "unavailable" = [(Unavailable, "")] + readsPrec _ "subscribe" = [(Subscribe, "")] + readsPrec _ "subscribed" = [(Subscribed, "")] + readsPrec _ "unsubscribe" = [(Unsubscribe, "")] + readsPrec _ "unsubscribed" = [(Unsubscribed, "")] + readsPrec _ "probe" = [(Probe, "")] + readsPrec _ _ = [] + +-- | All stanzas (IQ, message, presence) can cause errors, which in the Xmpp +-- stream looks like . These errors are +-- wrapped in the @StanzaError@ type. +-- TODO: Sender XML is (optional and is) not yet included. +data StanzaError = StanzaError + { stanzaErrorType :: StanzaErrorType + , stanzaErrorCondition :: StanzaErrorCondition + , stanzaErrorText :: Maybe (Maybe LangTag, Text) + , stanzaErrorApplicationSpecificCondition :: Maybe Element + } deriving (Eq, Show) + +-- | @StanzaError@s always have one of these types. +data StanzaErrorType = Cancel | -- ^ Error is unrecoverable - do not retry + Continue | -- ^ Conditition was a warning - proceed + Modify | -- ^ Change the data and retry + Auth | -- ^ Provide credentials and retry + Wait -- ^ Error is temporary - wait and retry + deriving (Eq) + +instance Show StanzaErrorType where + show Cancel = "cancel" + show Continue = "continue" + show Modify = "modify" + show Auth = "auth" + show Wait = "wait" + +instance Read StanzaErrorType where + readsPrec _ "auth" = [( Auth , "")] + readsPrec _ "cancel" = [( Cancel , "")] + readsPrec _ "continue" = [( Continue, "")] + readsPrec _ "modify" = [( Modify , "")] + readsPrec _ "wait" = [( Wait , "")] + readsPrec _ _ = [] + +-- | Stanza errors are accommodated with one of the error conditions listed +-- below. +data StanzaErrorCondition = BadRequest -- ^ Malformed XML. + | Conflict -- ^ Resource or session with + -- name already exists. + | FeatureNotImplemented + | Forbidden -- ^ Insufficient permissions. + | Gone -- ^ Entity can no longer be + -- contacted at this + -- address. + | InternalServerError + | ItemNotFound + | JidMalformed + | NotAcceptable -- ^ Does not meet policy + -- criteria. + | NotAllowed -- ^ No entity may perform + -- this action. + | NotAuthorized -- ^ Must provide proper + -- credentials. + | PaymentRequired + | RecipientUnavailable -- ^ Temporarily unavailable. + | Redirect -- ^ Redirecting to other + -- entity, usually + -- temporarily. + | RegistrationRequired + | RemoteServerNotFound + | RemoteServerTimeout + | ResourceConstraint -- ^ Entity lacks the + -- necessary system + -- resources. + | ServiceUnavailable + | SubscriptionRequired + | UndefinedCondition -- ^ Application-specific + -- condition. + | UnexpectedRequest -- ^ Badly timed request. + deriving Eq + +instance Show StanzaErrorCondition where + show BadRequest = "bad-request" + show Conflict = "conflict" + show FeatureNotImplemented = "feature-not-implemented" + show Forbidden = "forbidden" + show Gone = "gone" + show InternalServerError = "internal-server-error" + show ItemNotFound = "item-not-found" + show JidMalformed = "jid-malformed" + show NotAcceptable = "not-acceptable" + show NotAllowed = "not-allowed" + show NotAuthorized = "not-authorized" + show PaymentRequired = "payment-required" + show RecipientUnavailable = "recipient-unavailable" + show Redirect = "redirect" + show RegistrationRequired = "registration-required" + show RemoteServerNotFound = "remote-server-not-found" + show RemoteServerTimeout = "remote-server-timeout" + show ResourceConstraint = "resource-constraint" + show ServiceUnavailable = "service-unavailable" + show SubscriptionRequired = "subscription-required" + show UndefinedCondition = "undefined-condition" + show UnexpectedRequest = "unexpected-request" + +instance Read StanzaErrorCondition where + readsPrec _ "bad-request" = [(BadRequest , "")] + readsPrec _ "conflict" = [(Conflict , "")] + readsPrec _ "feature-not-implemented" = [(FeatureNotImplemented, "")] + readsPrec _ "forbidden" = [(Forbidden , "")] + readsPrec _ "gone" = [(Gone , "")] + readsPrec _ "internal-server-error" = [(InternalServerError , "")] + readsPrec _ "item-not-found" = [(ItemNotFound , "")] + readsPrec _ "jid-malformed" = [(JidMalformed , "")] + readsPrec _ "not-acceptable" = [(NotAcceptable , "")] + readsPrec _ "not-allowed" = [(NotAllowed , "")] + readsPrec _ "not-authorized" = [(NotAuthorized , "")] + readsPrec _ "payment-required" = [(PaymentRequired , "")] + readsPrec _ "recipient-unavailable" = [(RecipientUnavailable , "")] + readsPrec _ "redirect" = [(Redirect , "")] + readsPrec _ "registration-required" = [(RegistrationRequired , "")] + readsPrec _ "remote-server-not-found" = [(RemoteServerNotFound , "")] + readsPrec _ "remote-server-timeout" = [(RemoteServerTimeout , "")] + readsPrec _ "resource-constraint" = [(ResourceConstraint , "")] + readsPrec _ "service-unavailable" = [(ServiceUnavailable , "")] + readsPrec _ "subscription-required" = [(SubscriptionRequired , "")] + readsPrec _ "unexpected-request" = [(UnexpectedRequest , "")] + readsPrec _ "undefined-condition" = [(UndefinedCondition , "")] + readsPrec _ _ = [(UndefinedCondition , "")] + +-- ============================================================================= +-- OTHER STUFF +-- ============================================================================= + +data SaslFailure = SaslFailure { saslFailureCondition :: SaslError + , saslFailureText :: Maybe ( Maybe LangTag + , Text + ) + } deriving Show + +data SaslError = SaslAborted -- ^ Client aborted. + | SaslAccountDisabled -- ^ The account has been temporarily + -- disabled. + | SaslCredentialsExpired -- ^ The authentication failed because + -- the credentials have expired. + | SaslEncryptionRequired -- ^ The mechanism requested cannot be + -- used the confidentiality and + -- integrity of the underlying + -- stream is protected (typically + -- with TLS). + | SaslIncorrectEncoding -- ^ The base64 encoding is incorrect. + | SaslInvalidAuthzid -- ^ The authzid has an incorrect + -- format or the initiating entity + -- does not have the appropriate + -- permissions to authorize that ID. + | SaslInvalidMechanism -- ^ The mechanism is not supported by + -- the receiving entity. + | SaslMalformedRequest -- ^ Invalid syntax. + | SaslMechanismTooWeak -- ^ The receiving entity policy + -- requires a stronger mechanism. + | SaslNotAuthorized -- ^ Invalid credentials provided, or + -- some generic authentication + -- failure has occurred. + | SaslTemporaryAuthFailure -- ^ There receiving entity reported a + -- temporary error condition; the + -- initiating entity is recommended + -- to try again later. + +instance Show SaslError where + show SaslAborted = "aborted" + show SaslAccountDisabled = "account-disabled" + show SaslCredentialsExpired = "credentials-expired" + show SaslEncryptionRequired = "encryption-required" + show SaslIncorrectEncoding = "incorrect-encoding" + show SaslInvalidAuthzid = "invalid-authzid" + show SaslInvalidMechanism = "invalid-mechanism" + show SaslMalformedRequest = "malformed-request" + show SaslMechanismTooWeak = "mechanism-too-weak" + show SaslNotAuthorized = "not-authorized" + show SaslTemporaryAuthFailure = "temporary-auth-failure" + +instance Read SaslError where + readsPrec _ "aborted" = [(SaslAborted , "")] + readsPrec _ "account-disabled" = [(SaslAccountDisabled , "")] + readsPrec _ "credentials-expired" = [(SaslCredentialsExpired , "")] + readsPrec _ "encryption-required" = [(SaslEncryptionRequired , "")] + readsPrec _ "incorrect-encoding" = [(SaslIncorrectEncoding , "")] + readsPrec _ "invalid-authzid" = [(SaslInvalidAuthzid , "")] + readsPrec _ "invalid-mechanism" = [(SaslInvalidMechanism , "")] + readsPrec _ "malformed-request" = [(SaslMalformedRequest , "")] + readsPrec _ "mechanism-too-weak" = [(SaslMechanismTooWeak , "")] + readsPrec _ "not-authorized" = [(SaslNotAuthorized , "")] + readsPrec _ "temporary-auth-failure" = [(SaslTemporaryAuthFailure , "")] + readsPrec _ _ = [] + +-- The documentation of StreamErrorConditions is copied from +-- http://xmpp.org/rfcs/rfc6120.html#streams-error-conditions +data StreamErrorCondition + = StreamBadFormat -- ^ The entity has sent XML that cannot be processed. + | StreamBadNamespacePrefix -- ^ The entity has sent a namespace prefix that + -- is unsupported, or has sent no namespace + -- prefix on an element that needs such a prefix + | StreamConflict -- ^ The server either (1) is closing the existing stream + -- for this entity because a new stream has been initiated + -- that conflicts with the existing stream, or (2) is + -- refusing a new stream for this entity because allowing + -- the new stream would conflict with an existing stream + -- (e.g., because the server allows only a certain number + -- of connections from the same IP address or allows only + -- one server-to-server stream for a given domain pair as a + -- way of helping to ensure in-order processing + | StreamConnectionTimeout -- ^ One party is closing the stream because it + -- has reason to believe that the other party has + -- permanently lost the ability to communicate + -- over the stream. + | StreamHostGone -- ^ The value of the 'to' attribute provided in the + -- initial stream header corresponds to an FQDN that is no + -- longer serviced by the receiving entity + | StreamHostUnknown -- ^ The value of the 'to' attribute provided in the + -- initial stream header does not correspond to an FQDN + -- that is serviced by the receiving entity. + | StreamImproperAddressing -- ^ A stanza sent between two servers lacks a + -- 'to' or 'from' attribute, the 'from' or 'to' + -- attribute has no value, or the value violates + -- the rules for XMPP addresses + | StreamInternalServerError -- ^ The server has experienced a + -- misconfiguration or other internal error that + -- prevents it from servicing the stream. + | StreamInvalidFrom -- ^ The data provided in a 'from' attribute does not + -- match an authorized JID or validated domain as + -- negotiated (1) between two servers using SASL or + -- Server Dialback, or (2) between a client and a server + -- via SASL authentication and resource binding. + | StreamInvalidNamespace -- ^ The stream namespace name is something other + -- than "http://etherx.jabber.org/streams" (see + -- Section 11.2) or the content namespace declared + -- as the default namespace is not supported (e.g., + -- something other than "jabber:client" or + -- "jabber:server"). + | StreamInvalidXml -- ^ The entity has sent invalid XML over the stream to a + -- server that performs validation + | StreamNotAuthorized -- ^ The entity has attempted to send XML stanzas or + -- other outbound data before the stream has been + -- authenticated, or otherwise is not authorized to + -- perform an action related to stream negotiation; + -- the receiving entity MUST NOT process the offending + -- data before sending the stream error. + | StreamNotWellFormed -- ^ The initiating entity has sent XML that violates + -- the well-formedness rules of [XML] or [XML‑NAMES]. + | StreamPolicyViolation -- ^ The entity has violated some local service + -- policy (e.g., a stanza exceeds a configured size + -- limit); the server MAY choose to specify the + -- policy in the \ element or in an + -- application-specific condition element. + | StreamRemoteConnectionFailed -- ^ The server is unable to properly connect + -- to a remote entity that is needed for + -- authentication or authorization (e.g., in + -- certain scenarios related to Server + -- Dialback [XEP‑0220]); this condition is + -- not to be used when the cause of the error + -- is within the administrative domain of the + -- XMPP service provider, in which case the + -- condition is more + -- appropriate. + | StreamReset -- ^ The server is closing the stream because it has new + -- (typically security-critical) features to offer, because + -- the keys or certificates used to establish a secure context + -- for the stream have expired or have been revoked during the + -- life of the stream , because the TLS sequence number has + -- wrapped, etc. The reset applies to the stream and to any + -- security context established for that stream (e.g., via TLS + -- and SASL), which means that encryption and authentication + -- need to be negotiated again for the new stream (e.g., TLS + -- session resumption cannot be used) + | StreamResourceConstraint -- ^ The server lacks the system resources + -- necessary to service the stream. + | StreamRestrictedXml -- ^ he entity has attempted to send restricted XML + -- features such as a comment, processing instruction, + -- DTD subset, or XML entity reference + | StreamSeeOtherHost -- ^ The server will not provide service to the + -- initiating entity but is redirecting traffic to + -- another host under the administrative control of the + -- same service provider. + | StreamSystemShutdown -- ^ The server is being shut down and all active + -- streams are being closed. + | StreamUndefinedCondition -- ^ The error condition is not one of those + -- defined by the other conditions in this list + | StreamUnsupportedEncoding -- ^ The initiating entity has encoded the + -- stream in an encoding that is not supported + -- by the server or has otherwise improperly + -- encoded the stream (e.g., by violating the + -- rules of the [UTF‑8] encoding). + | StreamUnsupportedFeature -- ^ The receiving entity has advertised a + -- mandatory-to-negotiate stream feature that the + -- initiating entity does not support, and has + -- offered no other mandatory-to-negotiate + -- feature alongside the unsupported feature. + | StreamUnsupportedStanzaType -- ^ The initiating entity has sent a + -- first-level child of the stream that is not + -- supported by the server, either because the + -- receiving entity does not understand the + -- namespace or because the receiving entity + -- does not understand the element name for + -- the applicable namespace (which might be + -- the content namespace declared as the + -- default namespace) + | StreamUnsupportedVersion -- ^ The 'version' attribute provided by the + -- initiating entity in the stream header + -- specifies a version of XMPP that is not + -- supported by the server. + deriving Eq + +instance Show StreamErrorCondition where + show StreamBadFormat = "bad-format" + show StreamBadNamespacePrefix = "bad-namespace-prefix" + show StreamConflict = "conflict" + show StreamConnectionTimeout = "connection-timeout" + show StreamHostGone = "host-gone" + show StreamHostUnknown = "host-unknown" + show StreamImproperAddressing = "improper-addressing" + show StreamInternalServerError = "internal-server-error" + show StreamInvalidFrom = "invalid-from" + show StreamInvalidNamespace = "invalid-namespace" + show StreamInvalidXml = "invalid-xml" + show StreamNotAuthorized = "not-authorized" + show StreamNotWellFormed = "not-well-formed" + show StreamPolicyViolation = "policy-violation" + show StreamRemoteConnectionFailed = "remote-connection-failed" + show StreamReset = "reset" + show StreamResourceConstraint = "resource-constraint" + show StreamRestrictedXml = "restricted-xml" + show StreamSeeOtherHost = "see-other-host" + show StreamSystemShutdown = "system-shutdown" + show StreamUndefinedCondition = "undefined-condition" + show StreamUnsupportedEncoding = "unsupported-encoding" + show StreamUnsupportedFeature = "unsupported-feature" + show StreamUnsupportedStanzaType = "unsupported-stanza-type" + show StreamUnsupportedVersion = "unsupported-version" + +instance Read StreamErrorCondition where + readsPrec _ "bad-format" = [(StreamBadFormat , "")] + readsPrec _ "bad-namespace-prefix" = [(StreamBadNamespacePrefix , "")] + readsPrec _ "conflict" = [(StreamConflict , "")] + readsPrec _ "connection-timeout" = [(StreamConnectionTimeout , "")] + readsPrec _ "host-gone" = [(StreamHostGone , "")] + readsPrec _ "host-unknown" = [(StreamHostUnknown , "")] + readsPrec _ "improper-addressing" = [(StreamImproperAddressing , "")] + readsPrec _ "internal-server-error" = [(StreamInternalServerError , "")] + readsPrec _ "invalid-from" = [(StreamInvalidFrom , "")] + readsPrec _ "invalid-namespace" = [(StreamInvalidNamespace , "")] + readsPrec _ "invalid-xml" = [(StreamInvalidXml , "")] + readsPrec _ "not-authorized" = [(StreamNotAuthorized , "")] + readsPrec _ "not-well-formed" = [(StreamNotWellFormed , "")] + readsPrec _ "policy-violation" = [(StreamPolicyViolation , "")] + readsPrec _ "remote-connection-failed" = + [(StreamRemoteConnectionFailed, "")] + readsPrec _ "reset" = [(StreamReset , "")] + readsPrec _ "resource-constraint" = [(StreamResourceConstraint , "")] + readsPrec _ "restricted-xml" = [(StreamRestrictedXml , "")] + readsPrec _ "see-other-host" = [(StreamSeeOtherHost , "")] + readsPrec _ "system-shutdown" = [(StreamSystemShutdown , "")] + readsPrec _ "undefined-condition" = [(StreamUndefinedCondition , "")] + readsPrec _ "unsupported-encoding" = [(StreamUnsupportedEncoding , "")] + readsPrec _ "unsupported-feature" = [(StreamUnsupportedFeature , "")] + readsPrec _ "unsupported-stanza-type" = [(StreamUnsupportedStanzaType, "")] + readsPrec _ "unsupported-version" = [(StreamUnsupportedVersion , "")] + readsPrec _ _ = [(StreamUndefinedCondition , "")] + +data XmppStreamError = XmppStreamError + { errorCondition :: !StreamErrorCondition + , errorText :: !(Maybe (Maybe LangTag, Text)) + , errorXML :: !(Maybe Element) + } deriving (Show, Eq) + +data StreamError = StreamError XmppStreamError + | StreamUnknownError -- Something has gone wrong, but we don't + -- know what + | StreamNotStreamElement Text + | StreamInvalidStreamNamespace (Maybe Text) + | StreamInvalidStreamPrefix (Maybe Text) + | StreamWrongTo (Maybe Text) + | StreamWrongVersion (Maybe Text) + | StreamWrongLangTag (Maybe Text) + | StreamXMLError String -- If stream pickling goes wrong. + | StreamStreamEnd -- received closing stream tag + | StreamConnectionError + deriving (Show, Eq, Typeable) + +instance Exception StreamError +instance Error StreamError where noMsg = StreamConnectionError + +-- ============================================================================= +-- XML TYPES +-- ============================================================================= + + +-- | Wraps a function that MUST generate a stream of unique Ids. The +-- strings MUST be appropriate for use in the stanza id attirubte. +-- For a default implementation, see @idGenerator@. + +newtype IdGenerator = IdGenerator (IO Text) + + +-- | XMPP version number. Displayed as ".". 2.4 is lesser than +-- 2.13, which in turn is lesser than 12.3. + +data Version = Version { majorVersion :: !Integer + , minorVersion :: !Integer } deriving (Eq) + +-- If the major version numbers are not equal, compare them. Otherwise, compare +-- the minor version numbers. +instance Ord Version where + compare (Version amajor aminor) (Version bmajor bminor) + | amajor /= bmajor = compare amajor bmajor + | otherwise = compare aminor bminor + +instance Read Version where + readsPrec _ txt = (,"") <$> maybeToList (versionFromText $ Text.pack txt) + +instance Show Version where + show (Version major minor) = (show major) ++ "." ++ (show minor) + +-- Converts a "." numeric version number to a @Version@ object. +versionFromText :: Text.Text -> Maybe Version +versionFromText s = case AP.parseOnly versionParser s of + Right version -> Just version + Left _ -> Nothing + +-- Read numbers, a dot, more numbers, and end-of-file. +versionParser :: AP.Parser Version +versionParser = do + major <- AP.many1 AP.digit + AP.skip (== '.') + minor <- AP.many1 AP.digit + AP.endOfInput + return $ Version (read major) (read minor) + +-- | The language tag in accordance with RFC 5646 (in the form of "en-US"). It +-- has a primary tag and a number of subtags. Two language tags are considered +-- equal if and only if they contain the same tags (case-insensitive). +data LangTag = LangTag { primaryTag :: !Text + , subtags :: ![Text] } + +instance Eq LangTag where + LangTag p s == LangTag q t = Text.toLower p == Text.toLower q && + map Text.toLower s == map Text.toLower t + +instance Read LangTag where + readsPrec _ txt = (,"") <$> maybeToList (langTag $ Text.pack txt) + +instance Show LangTag where + show (LangTag p []) = Text.unpack p + show (LangTag p s) = Text.unpack . Text.concat $ + [p, "-", Text.intercalate "-" s] + +-- | Parses, validates, and possibly constructs a "LangTag" object. +langTag :: Text.Text -> Maybe LangTag +langTag s = case AP.parseOnly langTagParser s of + Right tag -> Just tag + Left _ -> Nothing + +-- Parses a language tag as defined by RFC 1766 and constructs a LangTag object. +langTagParser :: AP.Parser LangTag +langTagParser = do + -- Read until we reach a '-' character, or EOF. This is the `primary tag'. + primTag <- tag + -- Read zero or more subtags. + subTags <- many subtag + AP.endOfInput + return $ LangTag primTag subTags + where + tag :: AP.Parser Text.Text + tag = do + t <- AP.takeWhile1 $ AP.inClass tagChars + return t + subtag :: AP.Parser Text.Text + subtag = do + AP.skip (== '-') + subtag <- tag + return subtag + tagChars :: [Char] + tagChars = ['a'..'z'] ++ ['A'..'Z'] + +data ServerFeatures = SF + { stls :: !(Maybe Bool) + , saslMechanisms :: ![Text.Text] + , other :: ![Element] + } deriving Show + +data XmppConnectionState + = XmppConnectionClosed -- ^ No connection at this point. + | XmppConnectionPlain -- ^ Connection established, but not secured. + | XmppConnectionSecured -- ^ Connection established and secured via TLS. + deriving (Show, Eq, Typeable) + +data XmppConnection = XmppConnection + { sConSrc :: !(Source IO Event) + , sRawSrc :: !(Source IO BS.ByteString) + , sConPushBS :: !(BS.ByteString -> IO Bool) + , sConHandle :: !(Maybe Handle) + , sFeatures :: !ServerFeatures + , sConnectionState :: !XmppConnectionState + , sHostname :: !(Maybe Text) + , sJid :: !(Maybe Jid) + , sCloseConnection :: !(IO ()) + , sPreferredLang :: !(Maybe LangTag) + , sStreamLang :: !(Maybe LangTag) -- Will be a `Just' value + -- once connected to the + -- server. + , sStreamId :: !(Maybe Text) -- Stream ID as specified by + -- the server. + , sToJid :: !(Maybe Jid) -- JID to include in the + -- stream element's `to' + -- attribute when the + -- connection is secured. See + -- also below. + , sJidWhenPlain :: !Bool -- Whether or not to also include the + -- Jid when the connection is plain. + , sFrom :: !(Maybe Jid) -- From as specified by the + -- server in the stream + -- element's `from' + -- attribute. + } + +-- | +-- The Xmpp monad transformer. Contains internal state in order to +-- work with Pontarius. Pontarius clients needs to operate in this +-- context. +newtype XmppT m a = XmppT { runXmppT :: StateT XmppConnection m a } deriving (Monad, MonadIO) + +-- | Low-level and single-threaded Xmpp monad. See @Xmpp@ for a concurrent +-- implementation. +type XmppConMonad a = StateT XmppConnection IO a + +-- Make XmppT derive the Monad and MonadIO instances. +deriving instance (Monad m, MonadIO m) => MonadState (XmppConnection) (XmppT m) diff --git a/source/Network/Xmpp/Xep/ServiceDiscovery.hs b/source/Network/Xmpp/Xep/ServiceDiscovery.hs new file mode 100644 --- /dev/null +++ b/source/Network/Xmpp/Xep/ServiceDiscovery.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +-- XEP 0030: Service Discovery (disco) + +module Network.Xmpp.Xep.ServiceDiscovery + ( QueryInfoResult(..) + , Identity(..) + , queryInfo + , xmppQueryInfo + , Item + , queryItems + , DiscoError(..) + ) + where + +import Control.Applicative((<$>)) +import Control.Monad.IO.Class +import Control.Monad.Error + +import qualified Data.Text as Text +import Data.XML.Pickle +import Data.XML.Types + +import Network.Xmpp +import Network.Xmpp.Monad +import Network.Xmpp.Pickle +import Network.Xmpp.Types +import Network.Xmpp.Concurrent + +data DiscoError = DiscoNoQueryElement + | DiscoIQError IQError + | DiscoTimeout + | DiscoXMLError Element UnpickleError + + deriving (Show) + +instance Error DiscoError + +data Identity = Ident { iCategory :: Text.Text + , iName :: Maybe Text.Text + , iType :: Text.Text + , iLang :: Maybe LangTag + } deriving Show + +data QueryInfoResult = QIR { qiNode :: Maybe Text.Text + , qiIdentities :: [Identity] + , qiFeatures :: [Text.Text] + } deriving Show + +discoInfoNS :: Text.Text +discoInfoNS = "http://jabber.org/protocol/disco#info" + +infoN :: Text.Text -> Name +infoN name = (Name name (Just discoInfoNS) Nothing) + +xpIdentities = xpWrap (map $(\(cat, n, tp, lang) -> Ident cat n tp lang) . fst) + (map $ \(Ident cat n tp lang) -> ((cat, n, tp, lang),())) $ + xpElems (infoN "identity") + (xp4Tuple + (xpAttr "category" xpText) + (xpAttrImplied "name" xpText) + (xpAttr "type" xpText) + xpLangTag + ) + xpUnit + +xpFeatures :: PU [Node] [Text.Text] +xpFeatures = xpWrap (map fst) (map (,())) $ + xpElems (infoN "feature") + (xpAttr "var" xpText) + xpUnit + +xpQueryInfo = xpWrap (\(nd, (feats, ids)) -> QIR nd ids feats) + (\(QIR nd ids feats) -> (nd, (feats, ids))) $ + xpElem (infoN "query") + (xpAttrImplied "node" xpText) + (xp2Tuple + xpFeatures + xpIdentities + ) + +-- | Query an entity for it's identity and features +queryInfo :: Jid -- ^ Entity to query + -> Maybe Text.Text -- ^ Node + -> Session + -> IO (Either DiscoError QueryInfoResult) +queryInfo to node session = do + res <- sendIQ' (Just to) Get Nothing queryBody session + return $ case res of + IQResponseError e -> Left $ DiscoIQError e + IQResponseTimeout -> Left $ DiscoTimeout + IQResponseResult r -> case iqResultPayload r of + Nothing -> Left DiscoNoQueryElement + Just p -> case unpickleElem xpQueryInfo p of + Left e -> Left $ DiscoXMLError p e + Right r -> Right r + where + queryBody = pickleElem xpQueryInfo (QIR node [] []) + + +xmppQueryInfo :: Maybe Jid + -> Maybe Text.Text + -> XmppConMonad (Either DiscoError QueryInfoResult) +xmppQueryInfo to node = do + res <- xmppSendIQ' "info" to Get Nothing queryBody + return $ case res of + Left e -> Left $ DiscoIQError e + Right r -> case iqResultPayload r of + Nothing -> Left DiscoNoQueryElement + Just p -> case unpickleElem xpQueryInfo p of + Left e -> Left $ DiscoXMLError p e + Right r -> Right r + where + queryBody = pickleElem xpQueryInfo (QIR node [] []) + + +-- +-- Items +-- + +data Item = Item { itemJid :: Jid + , itemName :: Maybe Text.Text + , itemNode :: Maybe Text.Text + } deriving Show + +discoItemsNS :: Text.Text +discoItemsNS = "http://jabber.org/protocol/disco#items" + +itemsN :: Text.Text -> Name +itemsN n = Name n (Just discoItemsNS) Nothing + +xpItem = xpWrap (\(jid, name, node) -> Item jid name node) + (\(Item jid name node) -> (jid, name, node)) $ + xpElemAttrs (itemsN "item") + (xp3Tuple + (xpAttr "jid" xpPrim) + (xpAttrImplied "name" xpText) + (xpAttrImplied "node" xpText)) + + +xpQueryItems = xpElem (itemsN "query") + (xpAttrImplied "node" xpText) + (xpAll xpItem) + +-- | Query an entity for Items of a node +queryItems :: Jid -- ^ Entity to query + -> Maybe Text.Text -- ^ Node + -> Session + -> IO (Either DiscoError (Maybe Text.Text, [Item])) +queryItems to node session = do + res <- sendIQ' (Just to) Get Nothing queryBody session + return $ case res of + IQResponseError e -> Left $ DiscoIQError e + IQResponseTimeout -> Left $ DiscoTimeout + IQResponseResult r -> case iqResultPayload r of + Nothing -> Left DiscoNoQueryElement + Just p -> case unpickleElem xpQueryItems p of + Left e -> Left $ DiscoXMLError p e + Right r -> Right r + where + queryBody = pickleElem xpQueryItems (node, []) diff --git a/source/Text/XML/Stream/Elements.hs b/source/Text/XML/Stream/Elements.hs new file mode 100644 --- /dev/null +++ b/source/Text/XML/Stream/Elements.hs @@ -0,0 +1,108 @@ +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +module Text.XML.Stream.Elements where + +import Control.Applicative ((<$>)) +import Control.Exception +import Control.Monad.Trans.Class +import Control.Monad.Trans.Resource as R + +import qualified Data.ByteString as BS +import Data.Conduit as C +import Data.Conduit.List as CL +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Typeable +import Data.XML.Types + +import System.IO.Unsafe(unsafePerformIO) + +import qualified Text.XML.Stream.Render as TXSR +import Text.XML.Unresolved as TXU + +compressNodes :: [Node] -> [Node] +compressNodes [] = [] +compressNodes [x] = [x] +compressNodes (NodeContent (ContentText x) : NodeContent (ContentText y) : z) = + compressNodes $ NodeContent (ContentText $ x `Text.append` y) : z +compressNodes (x:xs) = x : compressNodes xs + +streamName :: Name +streamName = + (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) + +data StreamEnd = StreamEnd deriving (Typeable, Show) +instance Exception StreamEnd + +data InvalidXmppXml = InvalidXmppXml String deriving (Show, Typeable) + +instance Exception InvalidXmppXml + +parseElement txt = documentRoot $ TXU.parseText_ TXU.def txt + +elements :: R.MonadThrow m => C.Conduit Event m Element +elements = do + x <- C.await + case x of + Just (EventBeginElement n as) -> do + goE n as >>= C.yield + elements + Just (EventEndElement streamName) -> lift $ R.monadThrow StreamEnd + Nothing -> return () + _ -> lift $ R.monadThrow $ InvalidXmppXml $ "not an element: " ++ show x + where + many' f = + go id + where + go front = do + x <- f + case x of + Left x -> return $ (x, front []) + Right y -> go (front . (:) y) + goE n as = do + (y, ns) <- many' goN + if y == Just (EventEndElement n) + then return $ Element n as $ compressNodes ns + else lift $ R.monadThrow $ InvalidXmppXml $ + "Missing close tag: " ++ show n + goN = do + x <- await + case x of + Just (EventBeginElement n as) -> (Right . NodeElement) <$> goE n as + Just (EventInstruction i) -> return $ Right $ NodeInstruction i + Just (EventContent c) -> return $ Right $ NodeContent c + Just (EventComment t) -> return $ Right $ NodeComment t + Just (EventCDATA t) -> return $ Right $ NodeContent $ ContentText t + _ -> return $ Left x + + +openElementToEvents :: Element -> [Event] +openElementToEvents (Element name as ns) = EventBeginElement name as : goN ns [] + where + goE (Element name' as' ns') = + (EventBeginElement name' as' :) + . goN ns' + . (EventEndElement name' :) + goN [] = id + goN [x] = goN' x + goN (x:xs) = goN' x . goN xs + goN' (NodeElement e) = goE e + goN' (NodeInstruction i) = (EventInstruction i :) + goN' (NodeContent c) = (EventContent c :) + goN' (NodeComment t) = (EventComment t :) + +elementToEvents :: Element -> [Event] +elementToEvents e@(Element name _ _) = openElementToEvents e ++ [EventEndElement name] + + +renderOpenElement :: Element -> BS.ByteString +renderOpenElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO + $ CL.sourceList (openElementToEvents e) $$ TXSR.renderText def =$ CL.consume + +renderElement :: Element -> BS.ByteString +renderElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO + $ CL.sourceList (elementToEvents e) $$ TXSR.renderText def =$ CL.consume + +ppElement :: Element -> String +ppElement = Text.unpack . Text.decodeUtf8 . renderElement