pontarius-xmpp 0.0.7.0 → 0.1.0.0
raw patch · 47 files changed
+3664/−5696 lines, 47 filesdep +attoparsecdep +base64-bytestringdep +binarydep −asn1-datadep −base64-stringdep −cerealdep ~basedep ~bytestringdep ~containerssetup-changednew-component:exe:pontarius-xmpp-echoclientbinary-added
Dependencies added: attoparsec, base64-bytestring, binary, conduit, data-default, lifted-base, resourcet, split, stm, void, xml-conduit, xml-picklers
Dependencies removed: asn1-data, base64-string, cereal, certificate, enumerator, parsec, ranges, text-icu, time, utf8-string, uuid, xml-enumerator
Dependency ranges changed: base, bytestring, containers, crypto-api, cryptohash, mtl, network, pureMD5, random, stringprep, text, tls, tls-extra, transformers, xml-types
Files
- Documentation/Pontarius XMPP Manual.lyx +0/−591
- Documentation/Pontarius XMPP Manual.pdf binary
- Documentation/Software Requirements Specification for Pontarius XMPP.lyx +0/−1311
- Documentation/Software Requirements Specification for Pontarius XMPP.pdf binary
- Examples/EchoClient.hs +0/−147
- LICENSE +13/−28
- Network/XMPP.hs +0/−83
- Network/XMPP/Address.hs +0/−189
- Network/XMPP/SASL.hs +0/−172
- Network/XMPP/Session.hs +0/−762
- Network/XMPP/Stanza.hs +0/−188
- Network/XMPP/Stream.hs +0/−525
- Network/XMPP/TLS.hs +0/−30
- Network/XMPP/Types.hs +0/−588
- Network/XMPP/Utilities.hs +0/−62
- README +0/−22
- Setup.hs +0/−1
- nohup.out +0/−942
- pontarius-xmpp.cabal +89/−55
- source/Network/Xmpp.hs +250/−0
- source/Network/Xmpp/Bind.hs +49/−0
- source/Network/Xmpp/Concurrent.hs +11/−0
- source/Network/Xmpp/Concurrent/IQ.hs +81/−0
- source/Network/Xmpp/Concurrent/Monad.hs binary
- source/Network/Xmpp/Concurrent/Threads.hs +235/−0
- source/Network/Xmpp/Concurrent/Types.hs +71/−0
- source/Network/Xmpp/Errors.hs +49/−0
- source/Network/Xmpp/IM.hs +7/−0
- source/Network/Xmpp/Jid.hs +205/−0
- source/Network/Xmpp/Marshal.hs +209/−0
- source/Network/Xmpp/Message.hs +34/−0
- source/Network/Xmpp/Monad.hs +238/−0
- source/Network/Xmpp/Pickle.hs +76/−0
- source/Network/Xmpp/Presence.hs +10/−0
- source/Network/Xmpp/Sasl.hs +55/−0
- source/Network/Xmpp/Sasl/Common.hs +199/−0
- source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs +137/−0
- source/Network/Xmpp/Sasl/Mechanisms/Plain.hs +76/−0
- source/Network/Xmpp/Sasl/Mechanisms/Scram.hs +164/−0
- source/Network/Xmpp/Sasl/StringPrep.hs +29/−0
- source/Network/Xmpp/Sasl/Types.hs +36/−0
- source/Network/Xmpp/Session.hs +43/−0
- source/Network/Xmpp/Stream.hs +172/−0
- source/Network/Xmpp/TLS.hs +72/−0
- source/Network/Xmpp/Types.hs +783/−0
- source/Network/Xmpp/Xep/ServiceDiscovery.hs +163/−0
- source/Text/XML/Stream/Elements.hs +108/−0
− Documentation/Pontarius XMPP Manual.lyx
@@ -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
− Documentation/Pontarius XMPP Manual.pdf
binary file changed (111393 → absent bytes)
− Documentation/Software Requirements Specification for Pontarius XMPP.lyx
@@ -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-<lyxtabular version="3" rows="20" columns="3">-<features tabularvalignment="middle">-<column alignment="center" valignment="top" width="0">-<column alignment="center" valignment="top" width="0">-<column alignment="center" valignment="top" width="0">-<row>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-Name (Mnemonic)-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-Version Number-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-Purpose-\end_layout--\end_inset-</cell>-</row>-<row>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-base-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-</row>-<row>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-base64-string-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-</row>-<row>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-binary-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-</row>-<row>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-bytestring-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-</row>-<row>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-containers-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-</row>-<row>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-crypto-api-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-</row>-<row>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-enumerator-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-</row>-<row>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-hslogger-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-</row>-<row>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-network-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-</row>-<row>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-pureMD5-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-</row>-<row>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-QuickCheck-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-</row>-<row>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-random-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-</row>-<row>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-regex-posix-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-</row>-<row>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-text-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-</row>-<row>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-tls-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-0.4.1-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-</row>-<row>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-transformers-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-</row>-<row>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-utf8-string-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-</row>-<row>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-xml-enumerator-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-</row>-<row>-<cell alignment="center" valignment="top" topline="true" bottomline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-xml-types-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" bottomline="true" leftline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-<cell alignment="center" valignment="top" topline="true" bottomline="true" leftline="true" rightline="true" usebox="none">-\begin_inset Text--\begin_layout Plain Layout-N/A-\end_layout--\end_inset-</cell>-</row>-</lyxtabular>--\end_inset---\end_layout--\begin_layout Standard-\begin_inset space \space{}-\end_inset---\end_layout--\begin_layout Standard-Every 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
− Documentation/Software Requirements Specification for Pontarius XMPP.pdf
binary file changed (138639 → absent bytes)
− Examples/EchoClient.hs
@@ -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
LICENSE view
@@ -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 <http://www.apache.org/licenses/LICENSE-2.0>. -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.
− Network/XMPP.hs
@@ -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--- <http://www.pontarius.org/> 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-
− Network/XMPP/Address.hs
@@ -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 }
− Network/XMPP/SASL.hs
@@ -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 }
− Network/XMPP/Session.hs
@@ -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 ("<?xml version='1.0'?><stream:stream to='" ++ hostName ++- "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.or" ++- "g/streams' version='1.0'>") (Left handle)- threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Left handle)- lift $ liftIO $ putMVar (stateThreadID state) threadID- return Nothing- Left e -> do- let clientState = stateClientState state- ((), clientState') <- lift $ runStateT (callback OpenStreamFailure) clientState- put $ state { stateShouldExit = True }- return $ Just e-- IEC (CESecureWithTLS certificate verifyCertificate callback) -> do- -- CEB.assert (not $ isTLSSecured (stateStreamState state)) (return ())- let Connected _ handle = stateConnectionState state- lift $ liftIO $ send "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>" (Left handle)- put $ state { stateStreamState = PreStream- , 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 $ "__________" ++ ("<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='SCRAM-SHA-1'>" ++ (CBBS.encode ("n,,n=" ++ userName ++ ",r=" ++ (toString rValue))) ++ "</auth>")- lift $ liftIO $ send ("<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='SCRAM-SHA-1'>" ++ (CBBS.encode ("n,,n=" ++ userName ++ ",r=" ++ (toString rValue))) ++ "</auth>") 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 ("<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:param" ++ "s:xml:ns:xmpp-bind\"></bind></iq>") handleOrTLSCtx--- return ()--- _ -> do--- lift $ liftIO $ send ("<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:param" ++ "s:xml:ns:xmpp-bind\"><resource>" ++ fromJust resource ++ "</resource></bind></iq>") handleOrTLSCtx--- return ()--- id <- liftIO $ nextID $ stateIDGenerator state--- lift $ liftIO $ send ("<iq type=\"set\" id=\"" ++ id ++ "\"><session xmlns=\"urn:ietf:params:xml:ns:xmpp-session\"/>" ++ "</iq>") handleOrTLSCtx------ -- TODO: Execute callback on iq result------ let callback = fromJust $ stateAuthenticateCallback state in do -- TODO: streamProperties "TODO" after success--- ((), clientState) <- lift $ runStateT (callback $ AuthenticateSuccess streamProperties "TODO" "todo") (stateClientState state) -- get proper resource value when moving to iq result--- put $ state { stateClientState = clientState--- , stateStreamState = PostFeatures streamProperties "TODO" }--- state' <- get--- return Nothing--- _ -> do--- let callback = fromJust $ 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 ("<?xml version='1.0'?><stream:stream to='" ++--- hostName ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++--- "streams' version='1.0'>") (Right tlsCtx)--- lift $ liftIO $ putStrLn "00000000000000000000000000000000"--- return Nothing------ IEE (EnumeratorXML (XEChallenge (Chal challenge))) -> do--- 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 "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/>" handleOrTLSCtx--- put $ state { stateAuthenticationState = AuthenticatingPreSuccess userName password resource }--- return ()--- return Nothing------ -- We have received a SASL "success" message over a secured connection--- -- TODO: Parse the success message?--- -- TODO: <?xml version='1.0'?>?--- IEE (EnumeratorXML (XESuccess (Succ _))) -> do--- let serverHost = "jonkristensen.com"--- let AuthenticatingPreSuccess userName _ resource = stateAuthenticationState state in do--- lift $ liftIO $ send ("<?xml version='1.0'?><stream:stream to='" ++ serverHost ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++ "streams' version='1.0'>") handleOrTLSCtx--- put $ state { stateAuthenticationState = AuthenticatedUnbound userName resource }--- return Nothing-- IEE EnumeratorDone ->- -- TODO: Exit?- return Nothing-- -- ---------------------------------------------------------------------------- -- XML EVENTS- -- ------------------------------------------------------------------------------- -- Ignore id="bind_1" and session IQ result, otherwise create client event--- IEE (EnumeratorXML (XEIQ iqEvent)) ->--- case shouldIgnoreIQ iqEvent of--- True ->--- return Nothing--- False -> do--- let stanzaID' = iqID iqEvent--- let newTimeouts = case stanzaID' of--- Just stanzaID'' ->--- case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of--- True -> filter (\ e -> e /= stanzaID'') (stateTimeoutStanzaIDs state)--- False -> (stateTimeoutStanzaIDs state)--- Nothing -> (stateTimeoutStanzaIDs state)--- let iqReceivedFunctions = map (\ x -> iqReceived x) (stateClientHandlers state)--- let functions = map (\ x -> case x of--- Just f -> Just (f iqEvent)--- Nothing -> Nothing) iqReceivedFunctions--- let functions' = case lookup (fromJust $ iqID $ iqEvent) (stateIQCallbacks state) of--- Just f -> (Just (f $ iqEvent)):functions--- Nothing -> functions--- let clientState = stateClientState state--- clientState' <- sendToClient functions' clientState--- put $ state { stateClientState = clientState', stateTimeoutStanzaIDs = newTimeouts }--- return Nothing------ -- 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'
− Network/XMPP/Stanza.hs
@@ -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']
− Network/XMPP/Stream.hs
@@ -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)---- <stream:stream> 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---- <stream:stream> 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 "<major>.<minor>" 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']
− Network/XMPP/TLS.hs
@@ -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 }
− Network/XMPP/Types.hs
@@ -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 <stanza-kind to='sender' type='error'>. 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 "<major>.<minor>".--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
− Network/XMPP/Utilities.hs
@@ -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 []
− README
@@ -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 <http://www.pontarius.org/> and the Pontarius-XMPP Hackage page <http://hackage.haskell.org/package/pontarius-xmpp/> for more-information.
Setup.hs view
@@ -1,3 +1,2 @@ import Distribution.Simple- main = defaultMain
− nohup.out
@@ -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 <command line>: 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 <command line>: 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
pontarius-xmpp.cabal view
@@ -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:
+ source/Network/Xmpp.hs view
@@ -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.+ --+ -- <http://xmpp.org/rfcs/rfc6120.html#stanzas-semantics-message>+ , 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)+ --+ -- <http://xmpp.org/rfcs/rfc6120.html#stanzas-semantics-iq>+ , 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
+ source/Network/Xmpp/Bind.hs view
@@ -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+ -- "<bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'/>"+ -- element, with a possible "<resource>[JID]</resource>"+ -- 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
+ source/Network/Xmpp/Concurrent.hs view
@@ -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
+ source/Network/Xmpp/Concurrent/IQ.hs view
@@ -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
+ source/Network/Xmpp/Concurrent/Monad.hs view
binary file changed (absent → 9978 bytes)
+ source/Network/Xmpp/Concurrent/Threads.hs view
@@ -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
+ source/Network/Xmpp/Concurrent/Types.hs view
@@ -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 _ = "<Interrupt>"++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+ }
+ source/Network/Xmpp/Errors.hs view
@@ -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 _ = ""
+ source/Network/Xmpp/IM.hs view
@@ -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
+ source/Network/Xmpp/Jid.hs view
@@ -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+ }
+ source/Network/Xmpp/Marshal.hs view
@@ -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+ )+ )
+ source/Network/Xmpp/Message.hs view
@@ -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
+ source/Network/Xmpp/Monad.hs view
@@ -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 "<?xml version='1.0' encoding='UTF-8' ?>"++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 "</stream:stream>" 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 </stream:stream> element from the server is returned.+xmppCloseStreams :: XmppConMonad ([Element], Bool)+xmppCloseStreams = do+ send <- gets sConPushBS+ cc <- gets sCloseConnection+ liftIO $ send "</stream:stream>"+ 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 ()
+ source/Network/Xmpp/Pickle.hs view
@@ -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
+ source/Network/Xmpp/Presence.hs view
@@ -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}
+ source/Network/Xmpp/Sasl.hs view
@@ -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
+ source/Network/Xmpp/Sasl/Common.hs view
@@ -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 <auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/> 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 <success xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/> 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
+ source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs view
@@ -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+ )
+ source/Network/Xmpp/Sasl/Mechanisms/Plain.hs view
@@ -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)
+ source/Network/Xmpp/Sasl/Mechanisms/Scram.hs view
@@ -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+ )
+ source/Network/Xmpp/Sasl/StringPrep.hs view
@@ -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
+ source/Network/Xmpp/Sasl/Types.hs view
@@ -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 ())
+ source/Network/Xmpp/Session.hs view
@@ -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
+ source/Network/Xmpp/Stream.hs view
@@ -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))
+ source/Network/Xmpp/TLS.hs view
@@ -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 "<starttls/>, waits for "<proceed/>", 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 ()
+ source/Network/Xmpp/Types.hs view
@@ -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+-- (<http://xmpp.org/rfcs/rfc6121.html#message-syntax-type>)+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 <stanza-kind to='sender' type='error'>. 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 \<text/\> 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+ -- <internal-server-error/> 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 "<major>.<minor>". 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 "<major>.<minor>" 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)
+ source/Network/Xmpp/Xep/ServiceDiscovery.hs view
@@ -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, [])
+ source/Text/XML/Stream/Elements.hs view
@@ -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