diff --git a/Documentation/Pontarius XMPP Manual.lyx b/Documentation/Pontarius XMPP Manual.lyx --- a/Documentation/Pontarius XMPP Manual.lyx +++ b/Documentation/Pontarius XMPP Manual.lyx @@ -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 diff --git a/Documentation/Software Requirements Specification for Pontarius XMPP.lyx b/Documentation/Software Requirements Specification for Pontarius XMPP.lyx --- a/Documentation/Software Requirements Specification for Pontarius XMPP.lyx +++ b/Documentation/Software Requirements Specification for Pontarius XMPP.lyx @@ -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 primitive, a specialized +REQ-37 The system shall support the 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 primitive, a +REQ-38 The system shall support the primitive, a \begin_inset Quotes eld \end_inset @@ -1357,7 +1365,7 @@ \end_layout \begin_layout Description -REQ-38 The system shall support the , or Info/Query, primitive, a +REQ-39 The system shall support the , 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 diff --git a/Examples/EchoClient.hs b/Examples/EchoClient.hs --- a/Examples/EchoClient.hs +++ b/Examples/EchoClient.hs @@ -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 diff --git a/Network/XMPP.hs b/Network/XMPP.hs --- a/Network/XMPP.hs +++ b/Network/XMPP.hs @@ -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 diff --git a/Network/XMPP/Address.hs b/Network/XMPP/Address.hs new file mode 100644 --- /dev/null +++ b/Network/XMPP/Address.hs @@ -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 . + +-} + + +-- 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 } diff --git a/Network/XMPP/Extensions/XEP0030.hs b/Network/XMPP/Extensions/XEP0030.hs deleted file mode 100644 --- a/Network/XMPP/Extensions/XEP0030.hs +++ /dev/null @@ -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 diff --git a/Network/XMPP/Extensions/XEP0115.hs b/Network/XMPP/Extensions/XEP0115.hs deleted file mode 100644 --- a/Network/XMPP/Extensions/XEP0115.hs +++ /dev/null @@ -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 - - - diff --git a/Network/XMPP/JID.hs b/Network/XMPP/JID.hs deleted file mode 100644 --- a/Network/XMPP/JID.hs +++ /dev/null @@ -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 . - --} - --- | --- 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 diff --git a/Network/XMPP/Session.hs b/Network/XMPP/Session.hs --- a/Network/XMPP/Session.hs +++ b/Network/XMPP/Session.hs @@ -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 ("" ++ fromJust resource ++ "") handleOrTLSCtx return () - r <- lift $ liftIO $ getID - lift $ liftIO $ send ("" ++ "") handleOrTLSCtx + id <- liftIO $ nextID $ stateIDGenerator state + lift $ liftIO $ send ("" ++ "") 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 ("" ++ reply' ++ "") 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 -> diff --git a/Network/XMPP/Stanza.hs b/Network/XMPP/Stanza.hs --- a/Network/XMPP/Stanza.hs +++ b/Network/XMPP/Stanza.hs @@ -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'] diff --git a/Network/XMPP/Stream.hs b/Network/XMPP/Stream.hs --- a/Network/XMPP/Stream.hs +++ b/Network/XMPP/Stream.hs @@ -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 = "" ++ (elementsToString $ presencePayload p) ++ "" 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 "" ++ (elementToString (Just p)) ++ "" 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 "" ++ (elementToString (Just p)) ++ "" 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 "" ++ (elementToString p) ++ "" 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 = "" ++ - (elementsToString $ messagePayload m) ++ "" +messageToXML Message { messageID = i, messageFrom = f, messageTo = t, messagePayload = p, messageType = ty } = "" ++ + (elementsToString $ p) ++ "" 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" diff --git a/Network/XMPP/Types.hs b/Network/XMPP/Types.hs --- a/Network/XMPP/Types.hs +++ b/Network/XMPP/Types.hs @@ -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 . 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 --- . 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]) diff --git a/Network/XMPP/Utilities.hs b/Network/XMPP/Utilities.hs --- a/Network/XMPP/Utilities.hs +++ b/Network/XMPP/Utilities.hs @@ -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) diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -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: -