pontarius-xmpp 0.0.5.0 → 0.0.6.0
raw patch · 14 files changed
+955/−721 lines, 14 filesdep +idna2008dep +parsecdep +stringprepdep −regex-posix
Dependencies added: idna2008, parsec, stringprep, text-icu
Dependencies removed: regex-posix
Files
- Documentation/Pontarius XMPP Manual.lyx +120/−14
- Documentation/Software Requirements Specification for Pontarius XMPP.lyx +80/−60
- Examples/EchoClient.hs +16/−4
- Network/XMPP.hs +10/−18
- Network/XMPP/Address.hs +216/−0
- Network/XMPP/Extensions/XEP0030.hs +0/−36
- Network/XMPP/Extensions/XEP0115.hs +0/−20
- Network/XMPP/JID.hs +0/−147
- Network/XMPP/Session.hs +59/−52
- Network/XMPP/Stanza.hs +114/−86
- Network/XMPP/Stream.hs +59/−58
- Network/XMPP/Types.hs +265/−145
- Network/XMPP/Utilities.hs +1/−39
- pontarius-xmpp.cabal +15/−42
Documentation/Pontarius XMPP Manual.lyx view
@@ -61,7 +61,7 @@ \begin_body \begin_layout Title-Pontarius XMPP 0.1 Manual (Second Draft)+Pontarius XMPP 0.1 Manual (Third Draft) \end_layout \begin_layout Author@@ -69,7 +69,7 @@ \end_layout \begin_layout Date-The 15th of June, 2011+The 6th of July, 2011 \end_layout \begin_layout Standard@@ -342,11 +342,64 @@ \end_layout \begin_layout Subsection+Managing XMPP addresses+\end_layout++\begin_layout Standard+There are four functions dealing with XMPP addresses (or JIDs, as they are+ also called):+\end_layout++\begin_layout Standard+\begin_inset listings+inline false+status open++\begin_layout Plain Layout++fromString :: String -> Maybe Address+\end_layout++\begin_layout Plain Layout++fromStrings :: Maybe String -> String ->+\end_layout++\begin_layout Plain Layout++ Maybe String -> Maybe Address+\end_layout++\begin_layout Plain Layout++isBare :: Address -> Bool+\end_layout++\begin_layout Plain Layout++isFull :: Address -> Bool+\end_layout++\end_inset+++\end_layout++\begin_layout Standard+These functions should be pretty self-explainatory to those who know the+ XMPP: Core standard.+ The fromString functions takes one to three strings and tries to construct+ an XMPP address.+ isBare and isFull checks whether or not the bare is full (has a resource+ value).+\end_layout++\begin_layout Subsection Sending stanzas \end_layout \begin_layout Standard-Sending messages and presence is trivial:+Sending messages is done using this function: \end_layout \begin_layout Standard@@ -361,54 +414,107 @@ \begin_layout Plain Layout - StateT s m ()+ Maybe (Message -> StateT s m Bool) -> \end_layout \begin_layout Plain Layout -sendPresence :: MonadIO m => Session s m -> Presence ->+ Maybe (Timeout, StateT s m ()) -> \end_layout \begin_layout Plain Layout - StateT s m ()+ Maybe (StreamError -> StateT s m ()) -> \end_layout +\begin_layout Plain Layout++ StateT s m () +\end_layout+ \end_inset \end_layout \begin_layout Standard-However, as Info/Query (IQ) get and set stanzas typically have a corresponding- IQ result stanza, we offer a way to define the callback to be used for- the IQ result immediately in the sendIQ function:+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 -sendIQ :: MonadIO m => Session s m -> IQ -> Maybe (IQ ->+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 - StateT s m Bool) -> StateT s m ()+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 optional callback function is executed first with the resulting IQ,- and its boolean return value signals whether or not the IQ result stanza- should be blocked from being sent through the stack of client handlers.+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
Documentation/Software Requirements Specification for Pontarius XMPP.lyx view
@@ -61,7 +61,7 @@ \begin_body \begin_layout Title-Software Requirements Specification for Pontarius XMPP 0.1 (First Draft)+Software Requirements Specification for Pontarius XMPP 0.1 (Second Draft) \end_layout \begin_layout Author@@ -69,7 +69,7 @@ \end_layout \begin_layout Date-15th of June 2011+6th of July 2011 \end_layout \begin_layout Standard@@ -119,9 +119,7 @@ \end_layout \begin_layout Standard-We are planning to include support for XMPP server components later on,- but we have currently not planned to include any XMPP server functionality.- Support for common extensions such as Instant Messaging, Data Forms, Service+Support for common extensions such as Instant Messaging, Data Forms, Service Discovery, etc. will \emph on@@ -136,6 +134,7 @@ \end_inset ) versions.+ Server components and XMPP server capabilities could also be added later. \end_layout \begin_layout Standard@@ -149,15 +148,13 @@ \end_inset solutions on top of Pontarius XMPP, we want Pontarius XMPP to be a general-purp-ose and de facto XMPP library for Haskell.- We want it to be correct, flexible and efficient to work in, and we hope- that the purely functional and type safe environment offered by Haskell- will help us to deliver that.+ose---and de facto---XMPP library for Haskell.+ It should be correct, flexible 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 or any other specifications in this document.+ XMPP Core specification or other specifications in this document. \end_layout \begin_layout Subsection@@ -280,11 +277,7 @@ \end_layout \begin_layout Standard-Pontarius XMPP 0.1 is primarly designed to be used with Haskell, but we will- develop C bindings for the library as well.- The amount of C developers and APIs are huge, and making a C port will- likely open up for other ports, probably more-so than any other language.- Furthermore, the primary language for accessing GNOME is C.+Pontarius XMPP 0.1 is designed to be used with Haskell. \end_layout \begin_layout Standard@@ -295,13 +288,13 @@ \end_layout \begin_layout Standard-Pontarius XMPP 0.1 must work with the (estimated) most popular free and open- source software XMPP server.+Pontarius XMPP 0.1 must work with (at least) the (estimated) most popular+ free and open source software XMPP server. \end_layout \begin_layout Standard-The only software using Pontarius XMPP (that we know of) is the Pontarius- XPMN library, which currently in (very early) development.+The only software using Pontarius XMPP (that we know of) is the (currently+ paused) Pontarius XPMN library, which currently in (very early) development. However, as mentioned above, the goal for Pontarius XMPP is to serve as a general-purpose library, so we are trying not to be customizing the library to be somehow specially tailored for Pontarius XPMN.@@ -310,8 +303,8 @@ \begin_layout Standard Pontarius XMPP 0.1 depends on the below (free and open source software) Haskell packages.- I have omitted specification number [...] and source, as they are all available- on Hackage.+ I have omitted specification number [...].+ I have also omitted the source, as they are all available on Hackage. \end_layout \begin_layout Standard@@ -979,7 +972,8 @@ \begin_layout Standard We expect developers using Pontarius XMPP 0.1 to understand the XMPP: Core- specification, Haskell, and monads, including the StateT monad transformer.+ specification (and its depending specifications), Haskell, and monads,+ including the StateT monad transformer. \end_layout \begin_layout Subsection@@ -988,22 +982,30 @@ \begin_layout Standard In addition to the requirements in XMPP: Core, XMPP applications should- be reliable in that they should be able to be online for a long period- of time, without problems of memory leaks, unnecessary CPU usage, or similar,- arising.- Passwords should not be saved in memory unnecessarily for an extended period- of time.+ 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 Subsection+\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 Pontarius XMPP 0.1 runs.+ where Pontarius XMPP 0.1 applications are built. \end_layout +\begin_layout Subsubsection+Apportioning of requirements +\end_layout++\begin_layout Standard+If IDNA2008 or the other stringprep-replacing specifications are not finished+ or otherwise not suitable to implement, we will fall back to implementing+ stringprep for Pontarius XMPP 0.1.+\end_layout+ \begin_layout Section Specific requirements \end_layout@@ -1031,8 +1033,8 @@ \end_layout \begin_layout Description-REQ-4 The system shall work against the (estimated) most popular free and- open source software XMPP server.+REQ-4 The system shall work against (at least) the (estimated) most popular+ free and open source software XMPP server. \end_layout \begin_layout Subsection@@ -1190,6 +1192,12 @@ The time-out interval should be customizable. \end_layout +\begin_layout Description+REQ-20 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 Subsection Performance requirements \end_layout@@ -1199,18 +1207,18 @@ \end_layout \begin_layout Description-REQ-20 Regular desktop computers should be able to run hundreds of Pontarius+REQ-21 Regular desktop computers should be able to run hundreds of Pontarius XMPP 0.1 clients. \end_layout \begin_layout Description-REQ-21 Pontarius XMPP 0.1 should support virtually as many stanzas per second+REQ-22 Pontarius XMPP 0.1 should support virtually as many stanzas per second as (non-throttled) XMPP servers are able to route. This goes for both lightweight, heavy and mixed stanzas. \end_layout \begin_layout Description-REQ-22 Processing (parsing, generating, and firing the event) a received+REQ-23 Processing (parsing, generating, and firing the event) a received stanza should take at most 0.01 seconds. \end_layout @@ -1223,24 +1231,24 @@ \end_layout \begin_layout Description-REQ-23 The system shall support one persistant TCP stream/connection between+REQ-24 The system shall support one persistant TCP stream/connection between the XMPP client and the XMPP server. \end_layout \begin_layout Description-REQ-24 The system shall determine the proper IPv4 or IPv6 address of the+REQ-25 The system shall determine the proper IPv4 or IPv6 address of the XMPP server, using the SRV Lookup process as explained in the 3.2.1 section of XMPP: Core, the fallback process defined i 3.2.2, with the exception of the case explained in 3.2.3. \end_layout \begin_layout Description-REQ-25 The system shall try to reconnect after a disconnection with a random+REQ-26 The system shall try to reconnect after a disconnection with a random delay between 0 and 60 seconds. \end_layout \begin_layout Description-REQ-26 The system shall try to reconnect with increased delays, in accordance+REQ-27 The system shall try to reconnect with increased delays, in accordance with the \begin_inset Quotes eld \end_inset@@ -1267,12 +1275,12 @@ \end_layout \begin_layout Description-REQ-27 The system shall make use of TLS session resumption when reconnecting+REQ-28 The system shall make use of TLS session resumption when reconnecting to the server, if the connection was TLS secured. \end_layout \begin_layout Description-REQ-28 The system shall support stream management, as described in section+REQ-29 The system shall support stream management, as described in section 4 of XMPP: Core. This includes opening the stream, make the appropriate stream configurations (such as stream properties and features), parse incoming data, restart@@ -1281,17 +1289,17 @@ \end_layout \begin_layout Description-REQ-29 The system shall support securing the stream with TLS, as described+REQ-30 The system shall support securing the stream with TLS, as described in section 5 of XMPP: Core. \end_layout \begin_layout Description-REQ-30 The system shall support authenticating with SASL, as described in+REQ-31 The system shall support authenticating with SASL, as described in section 6 of XMPP: Core. \end_layout \begin_layout Description-REQ-31 Being a client library, the system shall support the 'jabber:client'+REQ-32 Being a client library, the system shall support the 'jabber:client' namespace. The 'jabber:server' namespace shall be out of scope for the client. The client may use other namespaces if necessary, such as the ones for@@ -1299,16 +1307,16 @@ \end_layout \begin_layout Description-REQ-32 XML namespaces for stanzas should always be known to the client.+REQ-33 XML namespaces for stanzas should always be known to the client. \end_layout \begin_layout Description-REQ-33 The system shall always check for the appropriate features before+REQ-34 The system shall always check for the appropriate features before trying to use them. \end_layout \begin_layout Description-REQ-34 The system shall support and utilize the +REQ-35 The system shall support and utilize the \begin_inset Quotes eld \end_inset @@ -1320,13 +1328,13 @@ \end_layout \begin_layout Description-REQ-35 The system shall support a distributed network of clients and servers.+REQ-36 The system shall support a distributed network of clients and servers. Clients on one XMPP server should be able to communicate with server and clients on other networks. \end_layout \begin_layout Description-REQ-36 The system shall support the <presence/> primitive, a specialized+REQ-37 The system shall support the <presence/> primitive, a specialized \begin_inset Quotes eld \end_inset@@ -1345,7 +1353,7 @@ \end_layout \begin_layout Description-REQ-37 The system shall support the <message/> primitive, a +REQ-38 The system shall support the <message/> primitive, a \begin_inset Quotes eld \end_inset @@ -1357,7 +1365,7 @@ \end_layout \begin_layout Description-REQ-38 The system shall support the <iq/>, or Info/Query, primitive, a +REQ-39 The system shall support the <iq/>, or Info/Query, primitive, a \begin_inset Quotes eld \end_inset @@ -1369,29 +1377,41 @@ \end_layout \begin_layout Description-REQ-39 The system must offer timeout callbacks to be called if an asynchronous+REQ-40 The system must offer timeout callbacks to be called if an asynchronous result is not guaranteed to be produced in a timely fashion. \end_layout \begin_layout Description-REQ-40 The system must a convenient API to deal with stanza and stream errors.+REQ-41 The system must a convenient API to deal with stanza and stream errors. \end_layout \begin_layout Subsubsection RFC 6122: XMPP: Address Format \end_layout +\begin_layout Standard+As can be read in Section 1 of RFC 6122, the XMPP community has started+ discussions about moving from the 2003 version of IDNA (Internationalized+ Domain Names in Applications) to the new IDNA2008 standard.+ Unlike its predecessor, this new standard is not based on Stringprep, and+ RFC 6122 will be obsoleted when an alternative to the Nodeprep and Resourceprep+ profiles has been completed.+ XMPP software implementations are in encouraged by RFC 6122 to follow IDNA2008+ instead, and Pontarius XMPP should try to do that.+\end_layout+ \begin_layout Description-REQ-41 JIDs should be validated in accordance with the standard.+REQ-42 JIDs should be validated, transformed, and internationalized in accordanc+e with the successor to the stringprep profiles \end_layout \begin_layout Description-REQ-42 JIDs should support internationalization, as described in section- 3 of the standard.+REQ-43 JIDs should support internationalization of node names, domain names,+ and resource names, through IDNA2008. \end_layout \begin_layout Description-REQ-43 Dealing with JIDs should adhere to the security recommendations as+REQ-44 Dealing with JIDs should adhere to the security recommendations as mentioned in section 4 of the standard. \end_layout @@ -1400,7 +1420,7 @@ \end_layout \begin_layout Description-REQ-44 The project and its source code shall adhere to the guidelines prestented+REQ-45 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@@ -1410,7 +1430,7 @@ \end_layout \begin_layout Description-REQ-45 The system shall be +REQ-46 The system shall be \emph on extendable \emph default@@ -1418,7 +1438,7 @@ \end_layout \begin_layout Description-REQ-46 The system shall be +REQ-47 The system shall be \emph on reliable \emph default@@ -1427,7 +1447,7 @@ \end_layout \begin_layout Description-REQ-47 The system shall be +REQ-48 The system shall be \emph on secure \emph default
Examples/EchoClient.hs view
@@ -41,7 +41,7 @@ serverIdentifier = "jonkristensen.com" portNumber = 5222 resource = "echo-client"-password = ""+password = "substrat44" -- The client state, containing the required Pontarius XMPP Session object. It@@ -91,6 +91,8 @@ connect (DM.fromJust $ stateSession state) hostName portNumber (Just ("", \ x -> True)) (Just (userName, password, Just resource)) connectCallback+ id <- getID (DM.fromJust $ stateSession state)+ CMIC.liftIO $ putStrLn $ "Unique ID acquired: " ++ id injectAction (DM.fromJust $ stateSession state) Nothing (do CMIC.liftIO $ putStrLn "Async action!"; return ()) injectAction (DM.fromJust $ stateSession state) Nothing (do CMIC.liftIO $ putStrLn "Async action!"; return ()) injectAction (DM.fromJust $ stateSession state) Nothing (do CMIC.liftIO $ putStrLn "Async action!"; return ())@@ -113,8 +115,13 @@ case r of ConnectSuccess _ _ _ -> do sendPresence (DM.fromJust $ stateSession state)- (presence Nothing Nothing Nothing Nothing Available []) Nothing Nothing- Nothing+ Presence { presenceID = Nothing+ , presenceFrom = Nothing+ , presenceTo = Nothing+ , presenceXMLLang = Nothing+ , presenceType = Available+ , presencePayload = [] }+ Nothing Nothing Nothing _ -> do CMIC.liftIO $ putStrLn "Could not connect." return ()@@ -130,6 +137,11 @@ "Received a message; echoing it! By the way: Internal state is " ++ (show $ stateTest state) ++ "." sendMessage (DM.fromJust $ stateSession state)- (message Nothing Nothing (stanzaFrom $ messageStanza m) Nothing (messageType m) (messagePayload m))+ 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
Network/XMPP.hs view
@@ -39,12 +39,14 @@ -- This module will be documented soon. module Network.XMPP ( -- Network.XMPP.JID- JID (..)- , jid- , jidIsFull- , jidIsBare- , stringToJID- , jidToString+ Address (..)+ , Localpart+ , Serverpart+ , Resourcepart+ , isFull+ , isBare+ , fromString+ , fromStrings -- Network.XMPP.SASL , replyToChallenge1@@ -78,32 +80,22 @@ , From , To , XMLLang- , Stanza (..) , MessageType (..) , Message (..)- , message , PresenceType (..) , Presence (..)- , presence , IQ (..)- , iqGet- , iqSet- , iqResult- , iqStanza , iqPayloadNamespace , iqPayload- , getId- , iqAck , injectAction -- Network.XMPP.Utilities , elementToString , elementsToString- , getID -- Genrate an Id with 8 char- , getID_ ) where+ , getID ) where -import Network.XMPP.JID+import Network.XMPP.Address import Network.XMPP.SASL import Network.XMPP.Session import Network.XMPP.Stanza
+ Network/XMPP/Address.hs view
@@ -0,0 +1,216 @@+{-++Copyright © 2010-2011 Jon Kristensen.++This file is part of Pontarius XMPP.++Pontarius XMPP is free software: you can redistribute it and/or modify it under+the terms of the GNU Lesser General Public License as published by the Free+Software Foundation, either version 3 of the License, or (at your option) any+later version.++Pontarius XMPP is distributed in the hope that it will be useful, but WITHOUT+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS+FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more+details.++You should have received a copy of the GNU Lesser General Public License along+with Pontarius XMPP. If not, see <http://www.gnu.org/licenses/>.++-}+++-- TODO: Move away from stringprep for all three profiles.++-- TODO: When no longer using stringprep, do appropriate testing. (Including+-- testing addresses like a@b/c@d/e, a/b@c, a@/b, a/@b...)++-- TODO: Unicode 3.2 should be used.+++-- |+-- Module: $Header$+-- Description: Data type and utility functions for XMPP addresses (JIDs)+-- Copyright: Copyright © 2010-2011 Jon Kristensen+-- License: LGPL-3+--+-- Maintainer: info@pontarius.org+-- Stability: unstable+-- Portability: portable+--+-- This module deals with XMPP addresses (also known as JIDs and JabberIDs). For+-- more information on XMPP addresses, see RFC 6122: XMPP: Address Format.+--+-- Provided hostnames may contain international characters; Pontarius XMPP will+-- try to convert such hostnames to internationalized hostnames.+++module Network.XMPP.Address (fromString, fromStrings, isBare, isFull) where++import Network.XMPP.Types++import Data.Maybe (fromJust, isJust)+import Text.Parsec ((<|>), anyToken, char, eof, many, noneOf, parse)+import Text.Parsec.ByteString (GenParser)++import Text.StringPrep (StringPrepProfile (..), a1, b1, b2, c11, c12, c21, c22,+ c3, c4, c5, c6, c7, c8, c9, runStringPrep)+import Text.NamePrep (namePrepProfile)++import Data.Text.IDNA2008 (toASCII)++import Network.URI (isIPv4address, isIPv6address)++import qualified Data.ByteString.Char8 as DBC (pack)+import qualified Data.Text as DT (pack, unpack)+++-- |+-- Converts a string to an XMPP address.++fromString :: String -> Maybe Address++fromString s = fromStrings localpart serverpart resourcepart+ where+ Right (localpart, serverpart, resourcepart) =+ parse addressParts "" (DBC.pack s)+++-- |+-- Converts localpart, serverpart, and resourcepart strings to an XMPP address.++-- Runs the appropriate stringprep profiles and validates the parts.++fromStrings :: Maybe String -> String -> Maybe String -> Maybe Address++fromStrings l s r+ | serverpart == Nothing = Nothing+ | otherwise = if validateNonServerpart localpart &&+ isJust serverpart' &&+ validateNonServerpart resourcepart+ then Just (Address localpart (fromJust serverpart') resourcepart)+ else Nothing+ where++ -- Applies the nodeprep profile on the localpart string, if any.+ localpart :: Maybe String+ localpart = case l of+ Just l' -> case runStringPrep nodeprepProfile (DT.pack l') of+ Just l'' -> Just $ DT.unpack l''+ Nothing -> Nothing+ Nothing -> Nothing++ -- Applies the nameprep profile on the serverpart string.+ -- TODO: Allow unassigned?+ serverpart :: Maybe String+ serverpart = case runStringPrep (namePrepProfile False) (DT.pack s) of+ Just s' -> Just $ DT.unpack s'+ Nothing -> Nothing++ -- Applies the resourceprep profile on the resourcepart string, if any.+ resourcepart :: Maybe String+ resourcepart = case r of+ Just r' -> case runStringPrep resourceprepProfile (DT.pack r') of+ Just r'' -> Just $ DT.unpack r''+ Nothing -> Nothing+ Nothing -> Nothing++ -- Returns the serverpart if it was a valid IP or if the toASCII+ -- function was successful, or Nothing otherwise.+ serverpart' :: Maybe String+ serverpart' | isIPv4address s || isIPv6address s = Just s+ | otherwise = toASCII s++ -- Validates that non-serverpart strings have an appropriate length.+ validateNonServerpart :: Maybe String -> Bool+ validateNonServerpart Nothing = True+ validateNonServerpart (Just l) = validPartLength l+ where+ validPartLength :: String -> Bool+ validPartLength p = length p > 0 && length p < 1024+++-- | Returns True if the address is `bare', and False otherwise.++isBare :: Address -> Bool++isBare j | resourcepart j == Nothing = True+ | otherwise = False+++-- | Returns True if the address is `full', and False otherwise.++isFull :: Address -> Bool++isFull jid = not $ isBare jid+++-- Parses an address string and returns its three parts. It performs no+-- validation or transformations. We are using Parsec to parse the address.+-- There is no input for which 'addressParts' fails.++addressParts :: GenParser Char st (Maybe String, String, Maybe String)++addressParts = do++ -- Read until we reach an '@', a '/', or EOF.+ a <- many $ noneOf ['@', '/']++ -- Case 1: We found an '@', and thus the localpart. At least the serverpart+ -- is remaining. Read the '@' and until a '/' or EOF.+ do+ char '@'+ b <- many $ noneOf ['/']++ -- Case 1A: We found a '/' and thus have all the address parts. Read the+ -- '/' and until EOF.+ do+ char '/' -- Resourcepart remaining+ c <- many $ anyToken -- Parse resourcepart+ eof+ return (Just a, b, Just c)++ -- Case 1B: We have reached EOF; the address is in the form+ -- localpart@serverpart.+ <|> do+ eof+ return (Just a, b, Nothing)++ -- Case 2: We found a '/'; the address is in the form+ -- serverpart/resourcepart.+ <|> do+ char '/'+ b <- many $ anyToken+ eof+ return (Nothing, a, Just b)++ -- Case 3: We have reached EOF; we have an address consisting of only a+ -- serverpart.+ <|> do+ eof+ return (Nothing, a, Nothing)+++nodeprepProfile :: StringPrepProfile++nodeprepProfile = Profile { maps = [b1, b2]+ , shouldNormalize = True+ , prohibited = [a1] ++ [c11, c12, c21, c22, c3, c4, c5, c6, c7, c8, c9]+ , shouldCheckBidi = True }+++-- These needs to be checked for after normalization. We could also look up the+-- Unicode mappings and include a list of characters in the prohibited field+-- above. Let's defer that until we know that we are going to use stringprep.++nodeprepExtraProhibitedCharacters = ['\x22', '\x26', '\x27', '\x2F', '\x3A',+ '\x3C', '\x3E', '\x40']++++resourceprepProfile :: StringPrepProfile++resourceprepProfile = Profile { maps = [b1]+ , shouldNormalize = True+ , prohibited = [a1] ++ [c12, c21, c22, c3, c4, c5, c6, c7, c8, c9]+ , shouldCheckBidi = True }
− Network/XMPP/Extensions/XEP0030.hs
@@ -1,36 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}--module Network.XMPP.Extensions.XEP0030 (-Feature (..),-Identity (..),-ServiceDiscoveryEntity (..),-serviceDiscoveryHandler,-serviceDiscoveryQuery-) where--import Network.XMPP.Session-import Network.XMPP.Types--import Control.Monad.State (StateT)-import Control.Monad.IO.Class (liftIO, MonadIO)--data Feature = Feature { featureVar :: XMLString }--data Identity = Identity { identityCategory :: XMLString- , identityName :: Maybe XMLString- , identityType :: XMLString }--class (ClientState s m, MonadIO m) => ServiceDiscoveryEntity s m where- getFeatures :: JID -> StateT s m [Feature]- getIdentities :: JID -> StateT s m [Identity]--serviceDiscoveryHandler :: (ClientState s m, MonadIO m,- ServiceDiscoveryEntity s m) => ClientHandler s m--serviceDiscoveryHandler = serviceDiscoveryHandler--serviceDiscoveryQuery :: (ClientState s m, MonadIO m) => Session s m -> JID ->- StateT s m ([Feature], [Identity]) -> Maybe (Timeout, StateT s m ()) ->- Maybe (Either StreamError IQ) -> StateT s m ()--serviceDiscoveryQuery = serviceDiscoveryQuery
− Network/XMPP/Extensions/XEP0115.hs
@@ -1,20 +0,0 @@------------------------------------------------------------------------------------ Module : Network.XMPP.Extensions.XEP0115--- Copyright : Copyright © 2011, Jon Kristensen--- License : LGPL (Just (Version {versionBranch = [3], versionTags = []}))------ Maintainer : jon.kristensen@pontarius.org--- Stability : alpha--- Portability : ------ |-----------------------------------------------------------------------------------module Network.XMPP.Extensions.XEP0115 (--) where---
− Network/XMPP/JID.hs
@@ -1,147 +0,0 @@-{---Copyright © 2010-2011 Jon Kristensen.--This file is part of Pontarius XMPP.--Pontarius XMPP is free software: you can redistribute it and/or modify it under-the terms of the GNU Lesser General Public License as published by the Free-Software Foundation, either version 3 of the License, or (at your option) any-later version.--Pontarius XMPP is distributed in the hope that it will be useful, but WITHOUT-ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS-FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more-details.--You should have received a copy of the GNU Lesser General Public License along-with Pontarius XMPP. If not, see <http://www.gnu.org/licenses/>.---}---- |--- Module: $Header$--- Description: JabberID (JID) data type and utility functions--- Copyright: Copyright © 2010-2011 Jon Kristensen--- License: LGPL-3------ Maintainer: info@pontarius.org--- Stability: unstable--- Portability: portable------ JIDs are written in the format of `node@server/resource'. An example of a JID--- is `jonkri@jabber.org'.------ The node identifier is the part before the `@' character in Jabber IDs. Node--- names are optional. The server identifier is the part after the `@' character--- in Jabber IDs (and before the `/' character). The server identifier is the--- only required field of a JID. The server identifier MAY be an IP address but--- SHOULD be a fully qualified domain name. The resource identifier is the part--- after the `/' character in Jabber IDs. Like with node names, the resource--- identifier is optional.------ A JID without a resource identifier (i.e. a JID in the form of `node@server')--- is called `bare JID'. A JID with a resource identifier is called `full JID'.---- Node identifiers MUST be formatted in such a way so that the Nodeprep profile--- (see RFC 3920: XMPP Core, Appendix A) of RFC 3454: Preparation of--- Internationalized Strings (`stringprep') can be applied without failing.--- Servers MUST and clients SHOULD apply the Nodeprep profile to node names--- prior to comparing them. Node identifiers MUST NOT be more than 1023 bytes in--- length.------ If it is a domain name it MUST be an `internationalized domain name' as--- defined in RFC 3490: Internationalizing Domain Names in Applications (IDNA),--- to which RFC 3491: Nameprep: A Stringprep Profile for Internationalized--- Domain Names (IDN) can be applied without failing. Servers MUST and clients--- SHOULD first apply the Nameprep profile to the domain names prior to--- comparing them. Like with node names, server identifiers MUST NOT be more--- than 1023 bytes in length.------ A resource identifier has to be formatted in such a way so that the--- Resourceprep profile of RFC 3454: Preparation of Internationalized Strings--- (`stringprep') can be applied without failing. Servers MUST and clients--- SHOULD first apply the Resourceprep profile (see RFC 3920: XMPP Core,--- Appendix B) to resource names prior to comparing them. The resource--- identifier MUST MOT be more than 1023 bytes in length.------ Given the length of the `@' and `/' characters as well as the restrictions--- imposed on the node, server and resource identifiers, a JID will never be--- longer than 3071 bytes.---- TODO: Make the regular expression only match valid JIDs.--- TODO: Use Perl regular expressions to use non-capturing groups with "(?:"?--- TODO: Validate the input in the jid and stringToJID functions.--module Network.XMPP.JID ( jid- , jidIsFull- , jidIsBare- , stringToJID- , jidToString ) where--import Network.XMPP.Types--import Text.Regex.Posix ((=~))----- | Simple function to construct a JID. We will add validation to this function--- in a later release.--jid :: Maybe String -> String -> Maybe String -> JID-jid n s r = JID { jidNode = n, jidServer = s, jidResource = r }----- | Converts a (JID) String to a JID record.--stringToJID :: String -> Maybe JID--stringToJID string = matchToJID $ string =~ "^(([^@]+)@)?([^/]+)(/(.+))?$"- where- matchToJID [[_, _, "", server, _, ""]] =- Just JID { jidNode = Nothing, jidServer = server, jidResource = Nothing }- matchToJID [[_, _, node, server, _, ""]] =- Just JID { jidNode = Just node- , jidServer = server- , jidResource = Nothing }- matchToJID [[_, _, "", server, _, resource]] =- Just JID { jidNode = Nothing- , jidServer = server- , jidResource = Just resource }- matchToJID [[_, _, node, server, _, resource]] =- Just JID { jidNode = Just node- , jidServer = server- , jidResource = Just resource }- matchToJID _ = Nothing----- | Converts a JID to a String.--jidToString :: JID -> String--jidToString JID { jidNode = n, jidServer = s, jidResource = 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'----- | JIDs are written in the format of `node@server/resource'. A JID without a--- resource identifier (i.e. a JID in the form of `server' or `node@server')--- is called a `bare JID'. A JID with a resource identifier is called `full--- JID'. This function returns True if the JID is `bare' and False otherwise.--jidIsBare :: JID -> Bool-jidIsBare j | jidResource j == Nothing = True- | otherwise = False----- | JIDs are written in the format of `node@server/resource'. A JID without a--- resource identifier (i.e. a JID in the form of `server' or `node@server')--- is called a `bare JID'. A JID with a resource identifier is called `full--- JID'. This function returns True if the JID is `full' and False otherwise.---- This function is defined in terms of (not) jidIsBare.--jidIsFull :: JID -> Bool-jidIsFull jid = not $ jidIsBare jid
Network/XMPP/Session.hs view
@@ -71,9 +71,10 @@ , secureWithTLS , authenticate , session- , injectAction ) where+ , injectAction+ , getID ) where -import Network.XMPP.JID+import Network.XMPP.Address import Network.XMPP.SASL import Network.XMPP.Stanza import Network.XMPP.Stream@@ -129,7 +130,8 @@ -- 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) }+data Session s m = Session { sessionChannel :: Chan (InternalEvent s m)+ , sessionIDGenerator :: IDGenerator } -- | A client typically needs one or more @ClientHandler@ objects to interact@@ -185,9 +187,10 @@ session s h c = do threadID <- liftIO $ newEmptyMVar chan <- liftIO $ newChan- ((), clientState) <- runStateT c (putSession s $ session_ chan)+ idGenerator <- liftIO $ idGenerator "" -- TODO: Prefix+ ((), clientState) <- runStateT c (putSession s $ session_ chan idGenerator) (result, _) <- runStateT (stateLoop chan)- (defaultState chan threadID h clientState)+ (defaultState chan threadID h clientState idGenerator) case result of Just (CE.SomeException e) -> do liftIO $ putStrLn "Got an exception!"@@ -203,29 +206,30 @@ return () where -- session :: Chan (InternalEvent m s) -> Session m s -- TODO- session_ c = Session { sessionChannel = c }+ session_ c i = Session { sessionChannel = c, sessionIDGenerator = i } defaultState :: (MonadIO m, ClientState s m) => Chan (InternalEvent s m) -> MVar ThreadId ->- [ClientHandler s m] -> s -> State s m+ [ClientHandler s m] -> s -> IDGenerator -> State s m -defaultState c t h s = State { stateClientHandlers = h- , stateClientState = s- , stateChannel = c- , stateConnectionState = Disconnected- , stateStreamState = PreStream- , stateTLSState = NoTLS- , stateOpenStreamCallback = Nothing- , stateSecureWithTLSCallback = Nothing- , stateAuthenticateCallback = Nothing- , stateAuthenticationState = NoAuthentication- , stateResource = Nothing- , stateShouldExit = False- , stateThreadID = t- , statePresenceCallbacks = []- , stateMessageCallbacks = []- , stateIQCallbacks = []- , stateTimeoutStanzaIDs = [] }+defaultState c t h s i = State { stateClientHandlers = h+ , stateClientState = s+ , stateChannel = c+ , stateConnectionState = Disconnected+ , stateStreamState = PreStream+ , stateTLSState = NoTLS+ , stateOpenStreamCallback = Nothing+ , stateSecureWithTLSCallback = Nothing+ , stateAuthenticateCallback = Nothing+ , stateAuthenticationState = NoAuthentication+ , stateResource = Nothing+ , stateShouldExit = False+ , stateThreadID = t+ , statePresenceCallbacks = []+ , stateMessageCallbacks = []+ , stateIQCallbacks = []+ , stateTimeoutStanzaIDs = []+ , stateIDGenerator = i } -- TODO: Prefix connect :: MonadIO m => Session s m -> HostName -> PortNumber ->@@ -307,6 +311,9 @@ 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 @@ -348,6 +355,7 @@ , stateMessageCallbacks :: [(StanzaID, (Message -> StateT s m Bool))] , stateIQCallbacks :: [(StanzaID, (IQ -> StateT s m Bool))] , stateTimeoutStanzaIDs :: [StanzaID]+ , stateIDGenerator :: IDGenerator } @@ -466,8 +474,8 @@ _ -> 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 ()- r <- lift $ liftIO $ getID- lift $ liftIO $ send ("<iq type=\"set\" id=\"" ++ r ++ "\"><session xmlns=\"urn:ietf:params:xml:ns:xmpp-session\"/>" ++ "</iq>") handleOrTLSCtx+ 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 @@ -475,6 +483,7 @@ ((), clientState) <- lift $ runStateT (callback $ AuthenticateSuccess streamProperties "TODO" "todo") (stateClientState state) -- get proper resource value when moving to iq result put $ state { stateClientState = clientState , stateStreamState = PostFeatures streamProperties "TODO" }+ state' <- get return Nothing _ -> do let callback = fromJust $ stateSecureWithTLSCallback state in do@@ -489,7 +498,7 @@ let Connected (ServerAddress hostName _) handle = stateConnectionState state tlsCtx <- lift $ liftIO $ handshake' handle hostName let tlsCtx_ = fromJust tlsCtx- put $ (defaultState (stateChannel state) (stateThreadID state) (stateClientHandlers state) (stateClientState state)) { stateTLSState = PostHandshake tlsCtx_, stateConnectionState = (stateConnectionState state), stateSecureWithTLSCallback = (stateSecureWithTLSCallback state) }+ put $ (defaultState (stateChannel state) (stateThreadID state) (stateClientHandlers state) (stateClientState state) (stateIDGenerator state)) { stateTLSState = PostHandshake tlsCtx_, stateConnectionState = (stateConnectionState state), stateSecureWithTLSCallback = (stateSecureWithTLSCallback state) } threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Right tlsCtx_) -- double code lift $ liftIO $ putStrLn "00000000000000000000000000000000" lift $ liftIO $ swapMVar (stateThreadID state) threadID -- return value not used@@ -507,15 +516,16 @@ let challenge' = CBBS.decode challenge case stateAuthenticationState state of AuthenticatingPreChallenge1 userName password resource -> do+ id <- liftIO $ nextID $ stateIDGenerator state -- This is the first challenge - we need to calculate the reply- random <- lift $ liftIO $ getID -- TODO: Length and content.- case replyToChallenge1 challenge' serverHost userName password random of+ case replyToChallenge1 challenge' serverHost userName password id of Left reply -> do let reply' = (filter (/= '\n') (CBBS.encode reply)) lift $ liftIO $ send ("<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>" ++ reply' ++ "</response>") handleOrTLSCtx put $ state { stateAuthenticationState = AuthenticatingPreChallenge2 userName password resource } return () Right error -> do+ state' <- get lift $ liftIO $ putStrLn $ show error return () AuthenticatingPreChallenge2 userName password resource -> do@@ -550,7 +560,7 @@ True -> return Nothing False -> do- let stanzaID' = stanzaID $ iqStanza $ iqEvent+ let stanzaID' = iqID iqEvent let newTimeouts = case stanzaID' of Just stanzaID'' -> case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of@@ -561,7 +571,7 @@ let functions = map (\ x -> case x of Just f -> Just (f iqEvent) Nothing -> Nothing) iqReceivedFunctions- let functions' = case lookup (fromJust $ stanzaID $ iqStanza $ iqEvent) (stateIQCallbacks state) of+ let functions' = case lookup (fromJust $ iqID $ iqEvent) (stateIQCallbacks state) of Just f -> (Just (f $ iqEvent)):functions Nothing -> functions let clientState = stateClientState state@@ -570,7 +580,7 @@ return Nothing IEE (EnumeratorXML (XEPresence presenceEvent)) -> do- let stanzaID' = stanzaID $ presenceStanza $ presenceEvent+ let stanzaID' = presenceID $ presenceEvent let newTimeouts = case stanzaID' of Just stanzaID'' -> case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of@@ -587,7 +597,7 @@ return Nothing IEE (EnumeratorXML (XEMessage messageEvent)) -> do- let stanzaID' = stanzaID $ messageStanza $ messageEvent+ let stanzaID' = messageID $ messageEvent let newTimeouts = case stanzaID' of Just stanzaID'' -> case stanzaID'' `elem` (stateTimeoutStanzaIDs state) of@@ -604,14 +614,14 @@ return Nothing IEC (CEPresence presence stanzaCallback timeoutCallback streamErrorCallback) -> do- presence' <- case stanzaID $ presenceStanza presence of+ presence' <- case presenceID $ presence of Nothing -> do- id <- lift $ liftIO $ getID- return $ presence { presenceStanza = (presenceStanza presence) { stanzaID = Just (SID id) } }+ id <- liftIO $ nextID $ stateIDGenerator state+ return $ presence { presenceID = Just (SID id) } _ -> return presence case timeoutCallback of Just (t, timeoutCallback') ->- let stanzaID' = (fromJust $ stanzaID $ presenceStanza presence') in do+ let stanzaID' = (fromJust $ presenceID $ presence') in do registerTimeout (stateChannel state) stanzaID' t timeoutCallback' put $ state { stateTimeoutStanzaIDs = stanzaID':(stateTimeoutStanzaIDs state) } Nothing ->@@ -621,14 +631,14 @@ return Nothing IEC (CEMessage message stanzaCallback timeoutCallback streamErrorCallback) -> do- message' <- case stanzaID $ messageStanza message of+ message' <- case messageID message of Nothing -> do- id <- lift $ liftIO $ getID- return $ message { messageStanza = (messageStanza message) { stanzaID = Just (SID id) } }+ id <- liftIO $ nextID $ stateIDGenerator state+ return $ message { messageID = Just (SID id) } _ -> return message case timeoutCallback of Just (t, timeoutCallback') ->- let stanzaID' = (fromJust $ stanzaID $ messageStanza message') in do+ let stanzaID' = (fromJust $ messageID message') in do registerTimeout (stateChannel state) stanzaID' t timeoutCallback' put $ state { stateTimeoutStanzaIDs = stanzaID':(stateTimeoutStanzaIDs state) } Nothing ->@@ -638,26 +648,23 @@ return Nothing IEC (CEIQ iq stanzaCallback timeoutCallback stanzaErrorCallback) -> do- iq' <- case stanzaID $ iqStanza iq of+ iq' <- case iqID iq of Nothing -> do- id <- lift $ liftIO $ getID+ id <- liftIO $ nextID $ stateIDGenerator state return $ case iq of- IQGet {} -> do- iq { iqGetStanza = (iqStanza iq) { stanzaID = Just (SID id) } }- IQSet {} -> do- iq { iqSetStanza = (iqStanza iq) { stanzaID = Just (SID id) } }- IQResult {} -> do- iq { iqResultStanza = (iqStanza iq) { stanzaID = Just (SID id) } }+ IQReq r -> do+ IQReq (r { iqRequestID = Just (SID id) })+ IQRes r -> do+ IQRes (r { iqResponseID = Just (SID id) }) _ -> return iq case stanzaCallback of Just callback' -> case iq of- IQGet {} -> put $ state { stateIQCallbacks = (fromJust $ stanzaID $ iqStanza iq', callback'):(stateIQCallbacks state) }- IQSet {} -> put $ state { stateIQCallbacks = (fromJust $ stanzaID $ iqStanza iq', callback'):(stateIQCallbacks state) }+ IQReq {} -> put $ state { stateIQCallbacks = (fromJust $ iqID iq, callback'):(stateIQCallbacks state) } _ -> return () Nothing -> return () case timeoutCallback of Just (t, timeoutCallback') ->- let stanzaID' = (fromJust $ stanzaID $ iqStanza iq') in do+ let stanzaID' = (fromJust $ iqID iq') in do registerTimeout (stateChannel state) stanzaID' t timeoutCallback' put $ state { stateTimeoutStanzaIDs = stanzaID':(stateTimeoutStanzaIDs state) } Nothing ->
Network/XMPP/Stanza.hs view
@@ -29,126 +29,154 @@ -- Stability: unstable -- Portability: portable ----- This module will be documented soon.+-- 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. --- Received stanzas can be assumed to have their ID and to fields set. --- TODO: Handle error stanzas+module Network.XMPP.Stanza (+iqID,+iqFrom,+iqTo,+iqXMLLang,+iqPayload,+iqPayloadNamespace,+iqRequestPayloadNamespace,+iqResponsePayloadNamespace,+idGenerator,+nextID+) where -module Network.XMPP.Stanza ( StanzaID (SID)- , From- , To- , XMLLang- , Stanza (..)- , MessageType (..)- , Message (..)- , message- , PresenceType (..)- , Presence (..)- , presence- , IQ (..)- , getId -- Just return the Id of existing IQ- , iqGet- , iqSet- , iqResult- , iqStanza- , iqAck- , iqPayloadNamespace- , iqPayload ) where+import Network.XMPP.Address+import Network.XMPP.Types -import Network.XMPP.JID+import Data.IORef (atomicModifyIORef, newIORef)+import Data.XML.Types (Element, elementName, nameNamespace)+import Data.Text (unpack) -import Network.XMPP.Types -import Data.XML.Types-import qualified Data.Text as DT-import Data.Maybe (fromJust)+-- |+-- Returns the @StanzaID@ value of the @IQ@, if any. -stanza :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang -> Stanza+iqID :: IQ -> Maybe StanzaID -stanza i f t l = Stanza { stanzaID = i- , stanzaFrom = f- , stanzaTo = t- , stanzaLang = l }+iqID (IQReq i) = iqRequestID i+iqID (IQRes i) = iqResponseID i -message :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang ->- MessageType -> [Element] -> Message+-- |+-- Returns the @From@ @JID@ value of the @IQ@, if any. -message i f t l t_ p = Message { messageStanza = stanza i f t l- , messageType = t_- , messagePayload = p }+iqFrom :: IQ -> Maybe From +iqFrom (IQReq i) = iqRequestFrom i+iqFrom (IQRes i) = iqResponseFrom i -presence :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang ->- PresenceType -> [Element] -> Presence -presence i f t l t_ p = Presence { presenceStanza = Stanza { stanzaID = i- , stanzaFrom = f- , stanzaTo = t- , stanzaLang = l }- , presenceType = t_- , presencePayload = p }+-- |+-- Returns the @To@ @JID@ value of the @IQ@, if any. +iqTo :: IQ -> Maybe To -iqGet :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang -> Element ->- IQ+iqTo (IQReq i) = iqRequestTo i+iqTo (IQRes i) = iqResponseTo i -iqGet i f t l p = IQGet { iqGetStanza = Stanza { stanzaID = i- , stanzaFrom = f- , stanzaTo = t- , stanzaLang = l }- , iqGetPayload = p } +-- |+-- Returns the @XMLLang@ value of the @IQ@, if any. -iqSet :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang -> Element ->- IQ+iqXMLLang :: IQ -> Maybe XMLLang -iqSet i f t l p = IQSet { iqSetStanza = Stanza { stanzaID = i- , stanzaFrom = f- , stanzaTo = t- , stanzaLang = l }- , iqSetPayload = p }+iqXMLLang (IQReq i) = iqRequestXMLLang i+iqXMLLang (IQRes i) = iqResponseXMLLang i -iqResult :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang ->- Maybe Element -> IQ+-- |+-- Returns the @Element@ payload value of the @IQ@, if any. If the IQ in+-- question is of the "request" type, use @iqRequestPayload@ instead. -iqResult i f t l p = IQResult { iqResultStanza = Stanza { stanzaID = i- , stanzaFrom = f- , stanzaTo = t- , stanzaLang = l }- , iqResultPayload = p }+iqPayload :: IQ -> Maybe Element -iqAck :: StanzaID -> To -> IQ-iqAck s t = iqResult (Just s) Nothing (Just t) Nothing Nothing+iqPayload (IQReq i) = Just (iqRequestPayload i)+iqPayload (IQRes i) = iqResponsePayload i -iqStanza :: IQ -> Stanza-iqStanza (IQGet { iqGetStanza = s }) = s-iqStanza (IQSet { iqSetStanza = s }) = s-iqStanza (IQResult { iqResultStanza = s }) = s -iqPayload :: IQ -> Maybe Element-iqPayload (IQGet {iqGetPayload = p}) = Just p-iqPayload (IQSet {iqSetPayload = p}) = Just p-iqPayload (IQResult {iqResultPayload = p}) = p+-- |+-- 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 (DT.unpack n)+ Just n -> Just (unpack n) --- Get the id from existing IQ-getId :: IQ -> StanzaID-getId iq = fromJust $ stanzaID $ iqStanza iq +-- |+-- Returns the namespace of the element of the @IQRequest@, if any. --- IM/RFC:--- data PresenceStatus = PS String deriving (Eq, Show)+iqRequestPayloadNamespace :: IQRequest -> Maybe String --- -- TODO: Validate input.+iqRequestPayloadNamespace i = let p = iqRequestPayload i in+ case nameNamespace $ elementName p of+ Nothing -> Nothing+ Just n -> Just (unpack n) --- presenceStatus :: String -> Maybe PresenceStatus--- presenceStatus s = Just (PS s)++-- |+-- 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 view
@@ -24,7 +24,8 @@ parseMessage ) where -import Network.XMPP.JID+import Network.XMPP.Address hiding (fromString)+import qualified Network.XMPP.Address as X import Network.XMPP.Types import Network.XMPP.Utilities import Network.XMPP.TLS@@ -169,23 +170,21 @@ presenceToXML p = "<presence" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementsToString $ presencePayload p) ++ "</presence>" where- s = presenceStanza p- from :: String- from = case stanzaFrom $ presenceStanza p of+ from = case presenceFrom p of -- TODO: Lower-case- Just s -> " from='" ++ (jidToString s) ++ "'"+ Just s -> " from='" ++ (show s) ++ "'" Nothing -> "" id' :: String- id' = case stanzaID s of+ id' = case presenceID p of Just (SID s) -> " id='" ++ s ++ "'" Nothing -> "" to :: String- to = case stanzaTo $ presenceStanza p of+ to = case presenceTo p of -- TODO: Lower-case- Just s -> " to='" ++ (jidToString s) ++ "'"+ Just s -> " to='" ++ (show s) ++ "'" Nothing -> "" type' :: String@@ -194,104 +193,104 @@ t -> " type='" ++ (presenceTypeToString t) ++ "'" iqToXML :: IQ -> String-iqToXML IQGet { iqGetStanza = s, iqGetPayload = p } =+iqToXML (IQReq (IQGet { iqRequestID = i, iqRequestPayload = p, iqRequestFrom = f, iqRequestTo = t })) = let type' = " type='get'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString (Just p)) ++ "</iq>" where from :: String- from = case stanzaFrom s of+ from = case f of -- TODO: Lower-case- Just s -> " from='" ++ (jidToString s) ++ "'"+ Just s -> " from='" ++ (show s) ++ "'" Nothing -> "" id' :: String- id' = case stanzaID s of+ id' = case i of Just (SID s) -> " id='" ++ s ++ "'" Nothing -> "" to :: String- to = case stanzaTo s of+ to = case t of -- TODO: Lower-case- Just s -> " to='" ++ (jidToString s) ++ "'"+ Just s -> " to='" ++ (show s) ++ "'" Nothing -> "" -iqToXML IQSet { iqSetStanza = s, iqSetPayload = p } =+iqToXML (IQReq (IQSet { iqRequestID = i, iqRequestPayload = p, iqRequestFrom = f, iqRequestTo = t })) = let type' = " type='set'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString (Just p)) ++ "</iq>" where from :: String- from = case stanzaFrom s of+ from = case f of -- TODO: Lower-case- Just s -> " from='" ++ (jidToString s) ++ "'"+ Just s -> " from='" ++ (show s) ++ "'" Nothing -> "" id' :: String- id' = case stanzaID s of+ id' = case i of Just (SID s) -> " id='" ++ s ++ "'" Nothing -> "" to :: String- to = case stanzaTo s of+ to = case t of -- TODO: Lower-case- Just s -> " to='" ++ (jidToString s) ++ "'"+ Just s -> " to='" ++ (show s) ++ "'" Nothing -> "" -iqToXML IQResult { iqResultStanza = s, iqResultPayload = p } =+iqToXML (IQRes (IQResult { iqResponseID = i, iqResponsePayload = p, iqResponseFrom = f, iqResponseTo = t })) = let type' = " type='result'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString p) ++ "</iq>" where from :: String- from = case stanzaFrom s of+ from = case f of -- TODO: Lower-case- Just s -> " from='" ++ (jidToString s) ++ "'"+ Just s -> " from='" ++ (show s) ++ "'" Nothing -> "" id' :: String- id' = case stanzaID s of+ id' = case i of Just (SID s) -> " id='" ++ s ++ "'" Nothing -> "" to :: String- to = case stanzaTo s of+ to = case t of -- TODO: Lower-case- Just s -> " to='" ++ (jidToString s) ++ "'"+ Just s -> " to='" ++ (show s) ++ "'" Nothing -> "" +-- TODO: Turn message errors into XML.+ messageToXML :: Message -> String-messageToXML m = "<message" ++ from ++ id' ++ to ++ type' ++ ">" ++- (elementsToString $ messagePayload m) ++ "</message>"+messageToXML Message { messageID = i, messageFrom = f, messageTo = t, messagePayload = p, messageType = ty } = "<message" ++ from ++ id' ++ to ++ type' ++ ">" +++ (elementsToString $ p) ++ "</message>" where- s = messageStanza m- from :: String- from = case stanzaFrom $ messageStanza m of+ from = case f of -- TODO: Lower-case- Just s -> " from='" ++ (jidToString s) ++ "'"+ Just s -> " from='" ++ (show s) ++ "'" Nothing -> "" id' :: String- id' = case stanzaID s of+ id' = case i of Just (SID s) -> " id='" ++ s ++ "'" Nothing -> "" to :: String- to = case stanzaTo $ messageStanza m of+ to = case t of -- TODO: Lower-case- Just s -> " to='" ++ (jidToString s) ++ "'"+ Just s -> " to='" ++ (show s) ++ "'" Nothing -> "" type' :: String- type' = case messageType m of+ type' = case ty of Normal -> "" t -> " type='" ++ (messageTypeToString t) ++ "'" parseIQ :: Element -> IQ parseIQ e | typeAttr == "get" = let (Just payloadMust) = payload- in iqGet idAttr fromAttr toAttr Nothing- payloadMust+ in IQReq (IQGet idAttr fromAttr toAttr Nothing+ payloadMust) | typeAttr == "set" = let (Just payloadMust) = payload- in iqSet idAttr fromAttr toAttr Nothing- payloadMust- | typeAttr == "result" = iqResult idAttr fromAttr toAttr Nothing- payload+ in IQReq (IQSet idAttr fromAttr toAttr Nothing+ payloadMust)+ | typeAttr == "result" = IQRes (IQResult idAttr fromAttr toAttr+ Nothing payload) where -- TODO: Many duplicate functions from parsePresence.@@ -306,15 +305,15 @@ -- Nothing -> Nothing Just a -> DT.unpack a - fromAttr :: Maybe JID+ fromAttr :: Maybe Address fromAttr = case attributeText fromName e of Nothing -> Nothing- Just a -> stringToJID $ DT.unpack a+ Just a -> X.fromString $ DT.unpack a - toAttr :: Maybe JID+ toAttr :: Maybe Address toAttr = case attributeText toName e of Nothing -> Nothing- Just a -> stringToJID $ DT.unpack a+ Just a -> X.fromString $ DT.unpack a idAttr :: Maybe StanzaID idAttr = case attributeText idName e of@@ -336,7 +335,7 @@ -- TODO: Parse xml:lang parsePresence :: Element -> Presence-parsePresence e = presence idAttr fromAttr toAttr Nothing typeAttr (elementChildren e)+parsePresence e = Presence idAttr fromAttr toAttr Nothing typeAttr (elementChildren e) where -- TODO: Many duplicate functions from parseIQ. @@ -345,15 +344,15 @@ Just t -> stringToPresenceType $ DT.unpack t Nothing -> Available - fromAttr :: Maybe JID+ fromAttr :: Maybe Address fromAttr = case attributeText fromName e of Nothing -> Nothing- Just a -> stringToJID $ DT.unpack a+ Just a -> X.fromString $ DT.unpack a - toAttr :: Maybe JID+ toAttr :: Maybe Address toAttr = case attributeText toName e of Nothing -> Nothing- Just a -> stringToJID $ DT.unpack a+ Just a -> X.fromString $ DT.unpack a idAttr :: Maybe StanzaID idAttr = case attributeText idName e of@@ -373,7 +372,7 @@ idName = fromString "id" parseMessage :: Element -> Message-parseMessage e = message idAttr fromAttr toAttr Nothing typeAttr (elementChildren e)+parseMessage e = Message idAttr fromAttr toAttr Nothing typeAttr (elementChildren e) where -- TODO: Many duplicate functions from parseIQ. @@ -382,15 +381,15 @@ Just t -> stringToMessageType $ DT.unpack t Nothing -> Normal - fromAttr :: Maybe JID+ fromAttr :: Maybe Address fromAttr = case attributeText fromName e of Nothing -> Nothing- Just a -> stringToJID $ DT.unpack a+ Just a -> X.fromString $ DT.unpack a - toAttr :: Maybe JID+ toAttr :: Maybe Address toAttr = case attributeText toName e of Nothing -> Nothing- Just a -> stringToJID $ DT.unpack a+ Just a -> X.fromString $ DT.unpack a idAttr :: Maybe StanzaID idAttr = case attributeText idName e of@@ -415,6 +414,8 @@ -- stringToPresenceType "dnd" = DoNotDisturb -- stringToPresenceType "xa" = ExtendedAway +stringToPresenceType "available" = Available -- TODO: Some client sent this+ stringToPresenceType "probe" = Probe -- stringToPresenceType "error" = PresenceError -- TODO: Special case @@ -442,14 +443,14 @@ presenceTypeToString Unsubscribed = "unsubscribed" stringToMessageType "chat" = Chat-stringToMessageType "error" = Error_+stringToMessageType "error" = Error stringToMessageType "groupchat" = Groupchat stringToMessageType "headline" = Headline stringToMessageType "normal" = Normal stringToMessageType s = OtherMessageType s messageTypeToString Chat = "chat"-messageTypeToString Error_ = "error"+messageTypeToString Error = "error" messageTypeToString Groupchat = "groupchat" messageTypeToString Headline = "headline" messageTypeToString Normal = "normal"
Network/XMPP/Types.hs view
@@ -13,27 +13,33 @@ {-# 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 (..),-JID (..),-StanzaID (..),-From,-To,+Address (..),+Localpart,+Serverpart,+Resourcepart, XMLLang,-Stanza (..),-MessageType (..),-Message (..),-PresenceType (..),-Presence (..),-IQ (..), InternalEvent (..), XMLEvent (..), ConnectionState (..),@@ -47,13 +53,10 @@ AuthenticateResult (..), ServerAddress (..), XMPPError (..),-StanzaError (..),-StanzaErrorType (..),-StanzaErrorCondition (..), Timeout, TimeoutEvent (..), StreamError (..),-XMLString+IDGenerator (..) ) where import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput)@@ -71,9 +74,221 @@ import qualified Control.Monad.Error as CME +import Data.IORef -type XMLString = String ++-- =============================================================================+-- STANZA TYPES+-- =============================================================================+++-- TODO: Would a Stanza class such as the one below be useful sometimes?+--+-- class Stanza a where+-- stanzaID :: a -> Maybe StanzaID+-- stanzaFrom :: a -> Maybe From+-- stanzaTo :: a -> Maybe To+-- stanzaXMLLang :: a -> Maybe XMLLang+++-- |+-- The StanzaID type wraps a string of random characters that in Pontarius XMPP+-- is guaranteed to be unique for the XMPP session. Clients can add a string+-- prefix for the IDs to guarantee that they are unique in a larger context by+-- specifying the stanzaIDPrefix setting. TODO++data StanzaID = SID String deriving (Eq, Show)+++-- |+-- @From@ is a readability type synonym for @Address@.++type From = Address+++-- |+-- @To@ is a readability type synonym for @Address@.++type To = Address+++-- |+-- An Info/Query (IQ) stanza is either of the type "request" ("get" or "set") or+-- "response" ("result" or "error"). The @IQ@ type wraps these two sub-types.++data IQ = IQReq IQRequest | IQRes IQResponse deriving (Eq, Show)+++-- |+-- A "request" Info/Query (IQ) stanza is one with either "get" or "set" as type.+-- They are guaranteed to always contain a payload.++data IQRequest = IQGet { iqRequestID :: Maybe StanzaID+ , iqRequestFrom :: Maybe From+ , iqRequestTo :: Maybe To+ , iqRequestXMLLang :: Maybe XMLLang+ , iqRequestPayload :: Element } |+ IQSet { iqRequestID :: Maybe StanzaID+ , iqRequestFrom :: Maybe From+ , iqRequestTo :: Maybe To+ , iqRequestXMLLang :: Maybe XMLLang+ , iqRequestPayload :: Element }+ deriving (Eq, Show)+++-- |+-- A "response" Info/Query (IQ) stanza is one with either "result" or "error" as+-- type.++data IQResponse = IQResult { iqResponseID :: Maybe StanzaID+ , iqResponseFrom :: Maybe From+ , iqResponseTo :: Maybe To+ , iqResponseXMLLang :: Maybe XMLLang+ , iqResponsePayload :: Maybe Element } |+ IQError { iqResponseID :: Maybe StanzaID+ , iqResponseFrom :: Maybe From+ , iqResponseTo :: Maybe To+ , iqResponseXMLLang :: Maybe XMLLang+ , iqResponsePayload :: Maybe Element+ , iqResponseStanzaError :: StanzaError }+ deriving (Eq, Show)+++-- |+-- The message stanza - either a message or a message error.++data Message = Message { messageID :: Maybe StanzaID+ , messageFrom :: Maybe From+ , messageTo :: Maybe To+ , messageXMLLang :: Maybe XMLLang+ , messageType :: MessageType+ , messagePayload :: [Element] } |+ MessageError { messageID :: Maybe StanzaID+ , messageFrom :: Maybe From+ , messageTo :: Maybe To+ , messageXMLLang :: Maybe XMLLang+ , messageErrorPayload :: Maybe [Element]+ , messageErrorStanzaError :: StanzaError }+ deriving (Eq, Show)+++-- |+-- @MessageType@ holds XMPP message types as defined in XMPP-IM. @Normal@ is the+-- default message type.++data MessageType = Chat |+ Error |+ Groupchat |+ Headline |+ Normal |+ OtherMessageType String deriving (Eq, Show)+++-- |+-- The presence stanza - either a presence or a presence error.++data Presence = Presence { presenceID :: Maybe StanzaID+ , presenceFrom :: Maybe From+ , presenceTo :: Maybe To+ , presenceXMLLang :: Maybe XMLLang+ , presenceType :: PresenceType+ , presencePayload :: [Element] } |+ PresenceError { presenceID :: Maybe StanzaID+ , presenceFrom :: Maybe From+ , presenceTo :: Maybe To+ , presenceXMLLang :: Maybe XMLLang+ , presenceErrorPayload :: Maybe [Element]+ , presenceErrorStanzaError :: StanzaError }+ deriving (Eq, Show)+++-- |+-- @PresenceType@ holds XMPP presence types. When a presence type is not+-- provided, we assign the @PresenceType@ value @Available@.++data PresenceType = Subscribe | -- ^ Sender wants to subscribe to presence+ Subscribed | -- ^ Sender has approved the subscription+ Unsubscribe | -- ^ Sender is unsubscribing from presence+ Unsubscribed | -- ^ Sender has denied or cancelled a+ -- subscription+ Probe | -- ^ Sender requests current presence;+ -- should only be used by servers+ Available | -- ^ Sender did not specify a type attribute+ Unavailable deriving (Eq, Show)+++-- |+-- All stanzas (IQ, message, presence) can cause errors, which in the XMPP+-- stream looks like <stanza-kind to='sender' type='error'>. These errors are+-- wrapped in the @StanzaError@ type.++data StanzaError = StanzaError { stanzaErrorType :: StanzaErrorType+ , stanzaErrorCondition :: StanzaErrorCondition+ , stanzaErrorText :: Maybe String+ , stanzaErrorApplicationSpecificCondition ::+ Maybe Element } deriving (Eq, Show)+++-- |+-- @StanzaError@s always have one of these types.++data StanzaErrorType = Cancel | -- ^ Error is unrecoverable - do not retry+ Continue | -- ^ Conditition was a warning - proceed+ Modify | -- ^ Change the data and retry+ Auth | -- ^ Provide credentials and retry+ Wait -- ^ Error is temporary - wait and retry+ deriving (Eq, Show)+++-- |+-- Stanza errors are accommodated with one of the error conditions listed below.++data StanzaErrorCondition = BadRequest | -- ^ Malformed XML+ Conflict | -- ^ Resource or session+ -- with name already+ -- exists+ FeatureNotImplemented |+ Forbidden | -- ^ Insufficient+ -- permissions+ Gone | -- ^ Entity can no longer+ -- be contacted at this+ -- address+ InternalServerError |+ ItemNotFound |+ JIDMalformed |+ NotAcceptable | -- ^ Does not meet policy+ -- criteria+ NotAllowed | -- ^ No entity may perform+ -- this action+ NotAuthorized | -- ^ Must provide proper+ -- credentials+ PaymentRequired |+ RecipientUnavailable | -- ^ Temporarily+ -- unavailable+ Redirect | -- ^ Redirecting to other+ -- entity, usually+ -- temporarily+ RegistrationRequired |+ RemoteServerNotFound |+ RemoteServerTimeout |+ ResourceConstraint | -- ^ Entity lacks the+ -- necessary system+ -- resources+ ServiceUnavailable |+ SubscriptionRequired |+ UndefinedCondition | -- ^ Application-specific+ -- condition+ UnexpectedRequest -- ^ Badly timed request+ deriving (Eq, Show)++++-- =============================================================================+-- OTHER STUFF+-- =============================================================================++ instance Eq ConnectionState where Disconnected == Disconnected = True (Connected p h) == (Connected p_ h_) = p == p_ && h == h_@@ -107,7 +322,7 @@ type Password = String --- | Readability type for (JID) resource identifier Strings.+-- | Readability type for (Address) resource identifier Strings. type Resource = String @@ -182,129 +397,6 @@ data Success = Succ String deriving (Show) -data StanzaID = SID String deriving (Eq, Show)-type From = JID-type To = JID-type XMLLang = String -- Validate, protect---data Stanza = Stanza { stanzaID :: Maybe StanzaID- , stanzaFrom :: Maybe From- , stanzaTo :: Maybe To- , stanzaLang :: Maybe XMLLang } deriving (Eq, Show)---data MessageType = Chat |- Error_ |- Groupchat |- Headline |- Normal | -- Default- OtherMessageType String deriving (Eq, Show)---data Message = Message { messageStanza :: Stanza- , messageType :: MessageType- , messagePayload :: [Element] } |- MessageError { messageErrorStanza :: Stanza- , messageErrorPayload :: Maybe [Element]- , messageErrorStanzaError :: StanzaError } deriving (Eq, Show)--data PresenceType = Subscribe | -- ^ Sender wants to subscribe to presence- Subscribed | -- ^ Sender has approved the subscription- Unsubscribe | -- ^ Sender is unsubscribing from presence- Unsubscribed | -- ^ Sender has denied or cancelled a- -- subscription- Probe | -- ^ Sender requests current presence;- -- should only be used by servers- -- PresenceError | -- ^ Processing or delivery of previously- -- sent presence stanza failed- Available | -- Not part of type='' [...]- -- Away |- -- Chat |- -- DoNotDisturb |- -- ExtendedAway |- Unavailable- deriving (Eq, Show)----- | Presence stanzas are used to express an entity's network availability.--data Presence = Presence { presenceStanza :: Stanza- , presenceType :: PresenceType- , presencePayload :: [Element] } |- PresenceError { presenceErrorStanza :: Stanza- , presenceErrorPayload :: Maybe [Element]- , presenceErrorStanzaError :: StanzaError } deriving (Eq, Show)----- | All stanzas (IQ, message, presence) can cause errors, which looks like--- <stanza-kind to='sender' type='error'>. These errors are of one of the--- types listed below.--data StanzaErrorType = Cancel | -- ^ Error is unrecoverable - do not retry- Continue | -- ^ Conditition was a warning - proceed- Modify | -- ^ Change the data and retry- Auth | -- ^ Provide credentials and retry- Wait -- ^ Error is temporary - wait and retry- deriving (Eq, Show)----- | The stanza errors are accommodated with one of the error conditions listed--- below. The ones that are not self-explainatory should be documented below.--data StanzaErrorCondition = BadRequest | -- ^ Malformed XML- Conflict | -- ^ Resource or session- -- with name already- -- exists- FeatureNotImplemented |- Forbidden | -- ^ Insufficient- -- permissions- Gone | -- ^ Entity can no longer- -- be contacted at this- -- address- InternalServerError |- ItemNotFound |- JIDMalformed |- NotAcceptable | -- ^ Does not meet policy- -- criteria- NotAllowed | -- ^ No entity may perform- -- this action- NotAuthorized | -- ^ Must provide proper- -- credentials- PaymentRequired |- RecipientUnavailable | -- ^ Temporarily- -- unavailable- Redirect | -- ^ Redirecting to other- -- entity, usually- -- temporarily- RegistrationRequired |- RemoteServerNotFound |- RemoteServerTimeout |- ResourceConstraint | -- ^ Entity lacks the- -- necessary system- -- resources- ServiceUnavailable |- SubscriptionRequired |- UndefinedCondition | -- ^ Application-specific- -- condition- UnexpectedRequest -- ^ Badly timed request- deriving (Eq, Show)---data IQ = IQGet { iqGetStanza :: Stanza, iqGetPayload :: Element } |- IQSet { iqSetStanza :: Stanza, iqSetPayload :: Element } |- IQResult { iqResultStanza :: Stanza- , iqResultPayload :: Maybe Element } |- IQError { iqErrorStanza :: Stanza, iqErrorPayload :: Maybe Element, iqErrorStanzaError :: StanzaError } deriving (Eq, Show)---data StanzaError = StanzaError { stanzaErrorType :: StanzaErrorType- , stanzaErrorCondition :: StanzaErrorCondition- , stanzaErrorText :: Maybe String- , stanzaErrorApplicationSpecificCondition ::- Maybe Element } deriving (Eq, Show)-- type StreamProperties = Float type StreamFeatures = String @@ -323,15 +415,43 @@ type Certificate = String -- TODO --- JID is a data type that has to be constructed in this module using either jid--- or stringToJID.+-- Address is a data type that has to be constructed in this module using either+-- address or stringToAddress. -data JID = JID { jidNode :: Maybe String- , jidServer :: String- , jidResource :: Maybe String } deriving (Eq, Show)+data Address = Address { localpart :: Maybe Localpart+ , serverpart :: Serverpart+ , resourcepart :: Maybe Resourcepart }+ deriving (Eq) +instance Show Address where+ show (Address { localpart = n, serverpart = s, resourcepart = r })+ | n == Nothing && r == Nothing = s+ | r == Nothing = let Just n' = n in n' ++ "@" ++ s+ | n == Nothing = let Just r' = r in s ++ "/" ++ r'+ | otherwise = let Just n' = n; Just r' = r+ in n' ++ "@" ++ s ++ "/" ++ r'++type Localpart = String+type Serverpart = String+type Resourcepart = String+ data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq) type Timeout = Int data StreamError = StreamError+++-- =============================================================================+-- XML TYPES+-- =============================================================================++type XMLLang = String+-- Validate, protect. See:+-- http://tools.ietf.org/html/rfc6120#section-8.1.5+-- http://www.w3.org/TR/2008/REC-xml-20081126/+-- http://www.rfc-editor.org/rfc/bcp/bcp47.txt+-- http://www.ietf.org/rfc/rfc1766.txt+++newtype IDGenerator = IDGenerator (IORef [String])
Network/XMPP/Utilities.hs view
@@ -37,9 +37,7 @@ -- TODO: Make it possible to customize length module Network.XMPP.Utilities ( elementToString- , elementsToString- , getID- , getID_) where+ , elementsToString ) where import Data.Word import Data.XML.Types@@ -48,42 +46,6 @@ import qualified Data.ByteString as DB import qualified Data.Map as DM import qualified Data.Text as DT------ =============================================================================--- ID Generation--- =============================================================================---characters :: String-characters = "abcdef0123456789"--getID :: IO String-getID = getID_ 8--getID_ :: Int -> IO String-getID_ i =- do se <- getSeed- let st = mkStdGen se- return $ take i (idSequence st)- where- idSequence :: StdGen -> String- idSequence st = [characters !! (fst $ rand st)] ++ idSequence (snd $ rand st)- rand :: StdGen -> (Int, StdGen)- rand st = randomR (0, length characters - 1) st--getSeed :: IO Int-getSeed =- do h <- openHandle- b <- hGetEntropy h 8- let w = DB.unpack b- let s = seed w- closeHandle h- return s- where seed :: [Word8] -> Int- seed [] = 1- seed (x:xs) = ((fromIntegral x) + 1) * (seed xs)
pontarius-xmpp.cabal view
@@ -1,66 +1,40 @@--- TODO: Set dependency versions.--- TODO: Highlighting bug: The last line of the description.- Name: pontarius-xmpp-Version: 0.0.5.0+Version: 0.0.6.0 Cabal-Version: >= 1.6 Build-Type: Simple License: LGPL-3 License-File: LICENSE-Copyright: Copyright © 2011, Jon Kristensen+Copyright: Copyright © 2011, Jon Kristensen Author: Jon Kristensen, Mahdi Abdinejadi Maintainer: jon.kristensen@pontarius.org Stability: alpha Homepage: http://www.pontarius.org/ Bug-Reports: mailto:info@pontarius.org-Package-URL: http://www.pontarius.org/releases/pontarius-xmpp-0.0.5.0.tar.gz-Synopsis: A (prototyped) secure and easy to use XMPP library+-- 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.+ 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 ==6.12.3+Tested-With: GHC ==7.0.2 -- Data-Files: -- Data-Dir: -- Extra-Source-Files: -- Extra-Tmp-Files: Library- Exposed-Modules: Network.XMPP, Network.XMPP.JID, Network.XMPP.SASL,+ Exposed-Modules: Network.XMPP, Network.XMPP.Address, Network.XMPP.SASL, Network.XMPP.Session, Network.XMPP.Stanza, Network.XMPP.Stream, Network.XMPP.TLS, Network.XMPP.Types, Network.XMPP.Utilities Exposed: True- Build-Depends: base >= 2 && < 5, enumerator, crypto-api, base64-string,- regex-posix, pureMD5, utf8-string, network, xml-types,+ Build-Depends: base >= 2 && < 5, parsec, enumerator, crypto-api,+ base64-string, pureMD5, utf8-string, network, xml-types, text, transformers, bytestring, binary, random,- xml-enumerator, tls ==0.4.1, containers, mtl- -- 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:---- Executable pontarius-xmpp-test- -- Main-Is: Test.hs- -- Build-Depends: hlogger ==0.0.3.0, base >= 2 && < 5, enumerator,- -- crypto-api, base64-string, regex-posix, pureMD5,- -- utf8-string, network, xml-types, text, transformers,- -- bytestring, binary, random, xml-enumerator, tls ==0.4.1,- -- containers+ xml-enumerator, tls ==0.4.1, containers, mtl, text-icu,+ stringprep, idna2008 ==0.0.1.0 -- Other-Modules: -- HS-Source-Dirs: -- Extensions:@@ -91,6 +65,5 @@ Type: darcs -- Module: Location: https://patch-tag.com/r/jonkri/pontarius-xmpp- Tag: 0.0.5.0+ Tag: 0.0.6.0 -- Subdir:-