pontarius-xmpp 0.0.2.0 → 0.0.3.0
raw patch · 12 files changed
+1818/−1466 lines, 12 filesdep ~hloggerdep ~tls
Dependency ranges changed: hlogger, tls
Files
- Examples/EchoClient.hs +73/−0
- Network/XMPP.hs +66/−0
- Network/XMPP/JID.hs +133/−0
- Network/XMPP/PontariusXMPP.hs +0/−1406
- Network/XMPP/SASL.hs +194/−0
- Network/XMPP/Session.hs +906/−0
- Network/XMPP/Stanza.hs +237/−0
- Network/XMPP/Utilities.hs +109/−0
- README +8/−12
- Test.hs +0/−35
- XTLS.hs +75/−0
- pontarius-xmpp.cabal +17/−13
+ Examples/EchoClient.hs view
@@ -0,0 +1,73 @@+{-++This file (EchoClient.hs) illustrates how to connect, authenticate and set a+presence with Pontarius XMPP. The contents of this file may be used freely, as+if it is in the public domain.++-}+++import Network.XMPP++import Control.Concurrent.Chan (Chan, readChan, writeChan)+import Data.Maybe+import Data.XML.Types+import qualified Data.Text as DT+++-- Account and server details.++host = "test.pontarius.org"+userName = "sprint3-xmpp"+server = "test.pontarius.org"+port = 5222+resource = "echo-client"+password = ""+++-- Creates a Pontarius XMPP session and requests to connect.++main :: IO ()+main =+ do (inEvents, outEvents) <- createSession+ writeChan outEvents $ XOEConnect host port+ loop inEvents outEvents+++-- All "in" events (incoming events to this program, events from Pontarius XMPP)+-- are being processed in this loop. A state variable could be added here.++loop :: Chan XMPPInEvent -> Chan XMPPOutEvent -> IO ()+loop c c_ =+ do e <- readChan c+ -- putStrLn $ "XMPPInEvent received: " ++ (show e)+ processEvent e+ loop c c_+ where+ processEvent :: XMPPInEvent -> IO ()+ + -- When connected, authenticate+ processEvent XIEConnectionSucceeded =+ writeChan c_ $ XOEAuthenticate userName password resource+ + -- When authenticated, set presence+ processEvent XIEAuthenticationSucceeded =+ writeChan c_ $ XOEPresence $+ presence Nothing Nothing Nothing Nothing Available []+ + -- Auto-accept subscriptions when asked and ask for subscription+ processEvent (XIEPresence (Presence { presenceStanza = stanza+ , presenceType = Subscribe })) = do+ let jid = stanzaFrom stanza+ writeChan c_ $ XOEPresence $ presence Nothing Nothing jid Nothing+ Subscribed []+ writeChan c_ $ XOEPresence $ presence Nothing Nothing jid Nothing+ Subscribe []+ return ()+ + -- Echo messages+ processEvent (XIEMessage m) =+ writeChan c_ $ XOEMessage $+ message Nothing Nothing (stanzaFrom $ messageStanza m) Nothing+ (messageType m) (messagePayload m)+ processEvent _ = return ()
+ Network/XMPP.hs view
@@ -0,0 +1,66 @@+-- | Module: $Header$+-- Description: A minimalistic and easy-to-use XMPP library+-- Copyright: Copyright © 2010-2011 Jon Kristensen+-- License: BSD-3+-- +-- Maintainer: info@pontarius.org+-- Stability: unstable+-- Portability: portable++-- | Pontarius XMPP aims to be a secure, concurrent/event-based and easy-to-use+-- XMPP library for Haskell. It is being actively developed.+-- +-- Note that we are not recommending anyone to use Pontarius XMPP at this time+-- as it's still in an experimental stage and will have its API and data types+-- modified frequently. See the project's web site at+-- <http://www.pontarius.org/projects/pontarius-xmpp/> for more information.+-- +-- This module will be documented soon.++module Network.XMPP ( -- Network.XMPP.JID+ JID (..)+ , jid+ , jidIsFull+ , jidIsBare+ , stringToJID+ , jidToString+ + -- Network.XMPP.SASL+ , replyToChallenge1+ + -- Network.XMPP.Session+ , XMPPInEvent (..)+ , XMPPOutEvent (..)+ , createSession+ + -- Network.XMPP.Stanza+ , StanzaID (SID)+ , From+ , To+ , XMLLang+ , Stanza (..)+ , MessageType (..)+ , Message (..)+ , message+ , PresenceType (..)+ , Presence (..)+ , presence+ , IQ (..)+ , iqGet+ , iqSet+ , iqResult+ , iqStanza+ , iqPayloadNamespace+ , iqPayload+ + -- Network.XMPP.Utilities+ , elementToString+ , elementsToString+ , getID+ , getID_ ) where++import Network.XMPP.JID+import Network.XMPP.SASL+import Network.XMPP.Session+import Network.XMPP.Stanza+import Network.XMPP.Utilities
+ Network/XMPP/JID.hs view
@@ -0,0 +1,133 @@+-- | Module: $Header$+-- Description: JabberID (JID) data type and utility functions+-- Copyright: Copyright © 2010-2011 Jon Kristensen+-- License: BSD-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 (jidNode, jidServer, jidResource)+ , jid+ , jidIsFull+ , jidIsBare+ , stringToJID+ , jidToString ) where++import Text.Regex.Posix ((=~))+++-- JID is a data type that has to be constructed in this module using either jid+-- or stringToJID.++data JID = JID { jidNode :: Maybe String+ , jidServer :: String+ , jidResource :: Maybe String } deriving (Eq, Show)+++-- | 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/PontariusXMPP.hs
@@ -1,1406 +0,0 @@--- | Module: $Header$--- Description: A minimalistic and easy-to-use XMPP library--- Copyright: Copyright © 2010-2011 Jon Kristensen--- License: BSD-3--- --- Maintainer: info@pontarius.org--- Stability: unstable--- Portability: portable--- --- Pontarius XMPP aims to be a secure, concurrent/event-based and easy-to-use--- XMPP library for Haskell. It is being actively developed.--- --- Note that we are not recommending anyone to use Pontarius XMPP at this time--- as it's still in an experimental stage and will have its API and data types--- modified frequently. See the project's web site at--- <http://www.pontarius.org/projects/pontarius-xmpp/> for more information.--- --- This module will be thoroughly documented soon.--module Network.XMPP.PontariusXMPP ( -- JID:- JID -- TODO: No external construction- , jid- , jidIsFull- , jidIsBare- , stringToJID- , jidToString- - -- ID Generation:- , getID- - -- Client API:- , ClientInEvent (..)- , ClientOutEvent (..)- , createPresence- , StanzaID- , PresenceStatus- , PresenceType (Available, Away, Chat, DoNotDisturb, ExtendedAway, Unavailable, Subscribe, Unsubscribe, Subscribed, Unsubscribed)- , StanzaErrorCondition (BadRequest, Conflict,- FeatureNotImplemented, Forbidden, Gone,- InternalServerError, ItemNotFound,- JIDMalformed, NotAcceptable, NotAllowed,- NotAuthorized, PaymentRequired,- RecipientUnavailable, Redirect,- RegistrationRequired, RemoteServerNotFound,- RemoteServerTimeout, ResourceConstraint,- ServiceUnavailable, SubscriptionRequired,- UndefinedCondition, UnexpectedRequest)- , StanzaErrorType (Cancel, Continue, Modify, Auth, Wait)- , connect- , presenceStatus- , presenceEvent- -- , subscriptionEvent- , iqGetEvent- , iqSetEvent- , iqResultEvent- , iqErrorEvent- , disconnectEvent ) where---import qualified Data.ByteString as DB-import Data.Int-import Data.XML.Types-import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)--import Text.Regex.Posix ((=~))-import Codec.Binary.UTF8.String-import Control.Concurrent (forkIO, threadDelay)-import Control.Monad.IO.Class (liftIO, MonadIO)-import Data.Enumerator (($$), Iteratee, continue, joinI,- run_, yield)-import Data.Enumerator.Binary (enumHandle, enumFile )-import qualified Data.Text as DT-import qualified Data.Text.Lazy as DTL-import Data.XML.Types -- (Event)-import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput)-import System.Log.HLogger-import System.Log.SimpleHLogger-import Network-import System.IO (BufferMode, BufferMode(NoBuffering))-import Text.XML.Enumerator.Parse (parseBytes, decodeEntities)-import Text.XML.Enumerator.Document (fromEvents)-import qualified Data.Enumerator.List as EL-import qualified Data.List as DL--- import Data.Text.Lazy.Internal-import Data.Digest.Pure.MD5--import qualified Text.XML.Enumerator.Document as D-import qualified Data.Enumerator as E--import qualified Data.List as DL--import qualified Codec.Binary.Base64.String as CBBS--import Data.Word (Word8)--import System.Crypto.Random-import Data.Word-import System.Random---- import qualified Data.ByteString as DBy-import qualified Data.ByteString.Lazy as DBL (ByteString, append, pack, fromChunks, toChunks, null)-import qualified Data.ByteString.Lazy.Char8 as DBLC (append, pack, unpack)-import qualified Data.ByteString.Char8 as DBC (pack, unpack)-import Data.ByteString.Internal (c2w)--import qualified Data.Binary as DBi (Binary, encode)--import Data.Char (isLatin1)-import GHC.IO.Handle (hClose)-import Network.TLS-import Data.String-import Data.Maybe-import qualified Data.Map as DM----- =============================================================================--- JID--- =============================================================================----- 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.---- | JIDs are written in the format of `node@server/resource'.--- --- 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). It is the only required field of a JID. It--- 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.----- JID is a data type that has to be constructed in this module using either jid--- or stringToJID.--data JID = JID { jidNode :: Maybe String- , jidServer :: String- , jidResource :: Maybe String } deriving (Eq, Show)----- | 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------ =============================================================================--- ID Generation--- =============================================================================----- TODO: This is a bit rushed as we are pressed for time.--characters :: String-characters = "abcdefghijklmnopqrstuvwxyz0123456789"--getID :: IO String-getID =- do se <- getSeed- let st = mkStdGen se- return $ take 8 (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)------ =============================================================================--- Client API--- =============================================================================----- TODO: "IQGet i f t e" instead of "IQGet (i, f, t, e)"?--- TODO: Messages, see http://www.ietf.org/rfc/rfc3921.txt, section 2.1.1.----- | A StanzaID is a eight character string which you can either generate--- yourself or have Pontarius XMPP generate for you.--data StanzaID = SID String 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)----- | Presence stanzas are used to express an entity's network availability.--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- Error | -- ^ Processing or delivery of previously- -- sent presence stanza failed- Available |- Away |- Chat |- DoNotDisturb |- ExtendedAway |- Unavailable- deriving (Eq, Show)---data PresenceStatus = PS String deriving (Eq, Show)----- TODO: Validate input.--presenceStatus :: String -> Maybe PresenceStatus-presenceStatus s = Just (PS s)----- TODO: Is the payload type below correct?--- TODO: Include presence type='error' information.---- data Presence = Presence { presenceID :: Maybe StanzaID--- , presenceFrom :: JID--- , presenceTo :: Maybe JID--- , payload :: Either SubscribeType (PresenceType--- , PresenceStatus) }----- | Connects to the given server and port using the provided user name and--- password. It returns a pair of channels, one channel used for delivering--- client events to Pontarius XMPP, and one to receive events from Pontarius--- XMPP.---- TODO: stopLogger logger--- TODO: Catch errors--connect :: String -> Integer -> JID -> String ->- IO (Chan ClientOutEvent, Chan ClientInEvent)--connect s po JID { jidNode = Just u, jidResource = r } pa =- do logger <- simpleLogger "PontariusXMPP"- logNotice logger "Pontarius XMPP has started"- - logInfo logger $ "Connecting to " ++ s ++ ":" ++ (show po) ++ "..."- -- Connect to the server, open stream- handle <- connectTo s (PortNumber $ fromInteger po)- hSetBuffering handle NoBuffering- hPutStr' handle s- - -- Create client "in" and "out" channels (naming from the perspective of- -- the client) as well as the internal event channel- inChan <- newChan- outChan <- newChan- internalChan <- newChan- - -- Start XML enumerator, which will read from the handle to generate the- -- relevant internal events- forkIO $ xmlEnumerator internalChan handle s logger- - -- Start to listen to client "out" events (client actions)- forkIO $ clientListener outChan internalChan logger- - -- Start the state loop, the main loop of Pontarius XMPP- forkIO $ stateLoop (defaultState s po u r pa handle) internalChan- inChan logger- - return (outChan, inChan)----- both presenceEvent and subscriptionEvent are presence stanzas-presenceEvent :: PresenceType -> Maybe PresenceStatus -> ClientOutEvent-presenceEvent t s = COESimplePresence (t, s)---- subscriptionEvent :: Maybe StanzaID -> JID -> SubscribeType -> ClientOutEvent--- subscriptionEvent i t j = COESubscription (i, t, j)---- id, to, payload-iqGetEvent :: Maybe StanzaID -> Maybe JID -> Element -> ClientOutEvent-iqGetEvent i j p = COEIQGet (i, j, p)--iqSetEvent :: Maybe StanzaID -> Maybe JID -> Element -> ClientOutEvent-iqSetEvent i j p = COEIQSet (i, j, p)--iqResultEvent :: Maybe StanzaID -> JID -> Maybe Element -> ClientOutEvent-iqResultEvent i j p = COEIQResult (i, j, p)--iqErrorEvent :: Maybe StanzaID -> JID -> Element -> Maybe Element ->- StanzaErrorType -> StanzaErrorCondition -> ClientOutEvent-iqErrorEvent i j p a t c = COEIQError (i, j, p, a, t, c)--disconnectEvent :: ClientOutEvent-disconnectEvent = COEDisconnect--createPresence :: Maybe JID -> Maybe PresenceType -> Maybe Element -> ClientOutEvent-createPresence j p e = COEComplexPresence (j, p, e)--data ClientOutEvent = COESimplePresence (PresenceType, Maybe PresenceStatus) |- COEComplexPresence (Maybe JID, Maybe PresenceType, Maybe Element) |- COEIQGet (Maybe StanzaID, Maybe JID, Element) |- COEIQSet (Maybe StanzaID, Maybe JID, Element) |- COEIQResult (Maybe StanzaID, JID, Maybe Element) |- COEIQError (Maybe StanzaID, JID, Element, Maybe Element,- StanzaErrorType, StanzaErrorCondition) |- COEDisconnect deriving (Eq, Show)---data ClientInEvent = CIEConnected |- CIEPresence (Maybe StanzaID, Maybe JID, Maybe JID,- Maybe PresenceType, [Element]) |- CIEIQGet (StanzaID, Maybe JID, Maybe JID, Element) |- CIEIQSet (StanzaID, Maybe JID, Maybe JID, Element) |- CIEIQResult (StanzaID, Maybe JID, Maybe JID, Maybe Element) |- -- CIEIQError (StanzaID, JID, Element, Maybe Element,- -- StanzaErrorType, StanzaErrorCondition) | -- TODO- CIEDisconnected deriving (Eq, Show)----- =============================================================================--- Internal Functions--- =============================================================================----- TODO: Add namespace support for stream/features?--- TODO: Add support for `ver optional' support for features?--- TODO: Presence priority?----- We use the InternalEvent data type for the channel to our internal enumerator--- (which processes the events that are fed into our state-modifying iteratee).--- An internal event is (so far) either a "XML event" (captured at depth level--- 1, such as a stanza) or a ClientOutEvent generated by the XMPP client.--data InternalEvent = IEX XMLEvent | IEC ClientOutEvent | IES SecurityEvent deriving (Show) -- WhiteSpaceEvent?---data SecurityEvent = TLSSucceeded TLSCtx | TLSFailed--instance Show SecurityEvent where- show (TLSSucceeded _) = "TLSSucceeded Ctx"- show TLSFailed = "TLSFailed"----- An XMLEvent is a high-level XMPP event generated by our XML parsing code.--data XMLEvent = XEBeginStream Stream | XEFeatures Features |- XEChallenge Challenge | XESuccess Success |- XEEndStream | XEIQ IQ | XEPresence Presence | XEOther String deriving (Show)----- Represents the top-level "<stream>" element.--data Stream = Stream { streamNamespace :: StreamNamespace- , streamID :: String- , streamVersion :: Float } deriving (Show)----- TODO: Do not make this assumption, but parse the element instead.--defaultStream id = Stream { streamNamespace = Client- , streamID = id- , streamVersion = 1.0 }----- The "<stream:features>" element.--data Features = Features { featuresStartTLS :: Bool- , featuresMechanisms :: [FeaturesMechanism]- , featuresCompressionMethods :: [CompressionMethod] } deriving (Show)----- TODO: Do not make this assumption, but parse the element instead.--featuresDefault = Features { featuresStartTLS = True,- featuresMechanisms = [DigestMD5],- featuresCompressionMethods = [] }----- TODO: Necessary?--data StreamNamespace = Client | Server deriving (Show)----- Authentication mechanisms. We only support DigestMD5 at this point.--data FeaturesMechanism = DigestMD5 | CramMD5 | Login | Plain | UnknownMechanism deriving (Show)--data UnknownMechanism = UM String deriving (Show)---data CompressionMethod = Zlib deriving (Show)----- Containers for information from SASL challenges and successes.--data Challenge = Chal String deriving (Show)--data Success = Succ String deriving (Show)---data SecurityState = NotTLSSecured | TLSSecured | SASLSecured deriving (Show, Eq)----xmlEnumerator :: Chan InternalEvent -> Handle -> String -> Logger -> IO ()-xmlEnumerator c h s l = do- logDebug l "xmlEnumerator: Starting to read insecure XML"- run_ $ enumHandle 1 h $$ joinI $ parseBytes decodeEntities- $$ xmlReader c [] 0- logDebug l "xmlEnumerator: Unsecure stream ended - performing TLS handshake"- t <- handshake' h s- case t of- Just tlsctx -> do logDebug l $ "xmlEnumerator: Handshake successful - st" ++- "arting to read secure XML"- writeChan c (IES (TLSSucceeded tlsctx))- run_ $ enumTLS tlsctx $$ joinI $ parseBytes decodeEntities- $$ xmlReader c [] 0- logDebug l $- "xmlEnumerator: Secure stream ended, exiting"- return ()- Nothing -> logDebug l $ "xmlEnumerator: TLS handshake failed" -- TODO: Event- return ()--enumTLS :: TLSCtx -> E.Enumerator DB.ByteString IO b-enumTLS c s = loop c s where- loop :: TLSCtx -> E.Step DB.ByteString IO b -> E.Iteratee DB.ByteString IO b- loop c (E.Continue k) =- do d <- recvData c- case DBL.null d of- True -> loop c (E.Continue k)- False -> k (E.Chunks $ DBL.toChunks d) E.>>== loop c- loop _ step = E.returnI step--hPutStr' :: Handle -> String -> IO ()-hPutStr' h s = do- hPutStr h $ encodeString "<?xml version='1.0'?><stream:stream to='" ++- s ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++- "streams' version='1.0'>"- hFlush h--getTLSParams :: TLSParams-getTLSParams = TLSParams { pConnectVersion = TLS10- , pAllowedVersions = [TLS10,TLS11]- , pCiphers = [cipher_AES256_SHA1] -- Check the rest- , pCompressions = [nullCompression]- , pWantClientCert = False- , pCertificates = []- , onCertificatesRecv = \_ -> return True } -- Verify cert chain--handshake' :: Handle -> String -> IO (Maybe TLSCtx)-handshake' h s = do- let t = getTLSParams- r <- makeSRandomGen- case r of- Right sr -> do- putStrLn $ show sr- c <- client t sr h- handshake c- sendData c $ DBLC.pack $ encodeString "<?xml version='1.0'?><stream:stream to='" ++- s ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++- "streams' version='1.0'>"- putStrLn ">>>>TLS data sended<<<<"- return (Just c)- Left ge -> do- putStrLn $ show ge- return Nothing----- TODO: Add logger--xmlReader :: Chan InternalEvent -> [Event] -> Int ->- Iteratee Event IO (Maybe Event)--xmlReader ch [EventBeginDocument] 0 = xmlReader ch [] 0---- TODO: Safe to start change level here? We are doing this since the stream can--- restart.--- TODO: l < 2?-xmlReader ch [EventBeginElement name attribs] l- | l < 3 && nameLocalName name == DT.pack "stream" &&- namePrefix name == Just (DT.pack "stream") = do- liftIO $ writeChan ch $ IEX $ XEBeginStream $ defaultStream "TODO"- xmlReader ch [] 1--xmlReader ch [EventEndElement name] 1- | namePrefix name == Just (DT.pack "stream") &&- nameLocalName name == DT.pack "stream" = do- liftIO $ writeChan ch $ IEX XEEndStream- return Nothing---- Check if counter is one to forward it to related function.--- Should replace "reverse ((EventEndElement n):es)" with es--- ...-xmlReader ch ((EventEndElement n):es) 1- | nameLocalName n == DT.pack "proceed" = E.yield Nothing (E.Chunks [])- | otherwise = do- -- liftIO $ putStrLn "Got an IEX Event..."- liftIO $ writeChan ch $ IEX (processEventList (DL.reverse ((EventEndElement n):es)))- xmlReader ch [] 1---- Normal condition, buffer the event to events list.-xmlReader ch es co = do- head <- EL.head- let co' = counter co head- liftIO $ putStrLn $ show co' ++ "\t" ++ show head -- for test- case head of- Just e -> xmlReader ch (e:es) co'- Nothing -> xmlReader ch es co'----- TODO: Generate real event.-processEventList :: [Event] -> XMLEvent-processEventList e- | namePrefix name == Just (DT.pack "stream") &&- nameLocalName name == DT.pack "features" = XEFeatures featuresDefault- | nameLocalName name == DT.pack "challenge" =- let EventContent (ContentText c) = head es in XEChallenge $ Chal $ DT.unpack c- | nameLocalName name == DT.pack "success" =- let EventContent (ContentText c) = head es in XESuccess $ Succ $ DT.unpack c- | nameLocalName name == DT.pack "iq" = XEIQ $ parseIQ $ eventsToElement e- | nameLocalName name == DT.pack "presence" = XEPresence $ parsePresence $ eventsToElement e- | otherwise = XEOther $ show $ nameLocalName name- where- (EventBeginElement name attribs) = head e- es = tail e--eventsToElement :: [Event] -> Element-eventsToElement e = do- documentRoot $ fromJust (run_ $ enum e $$ fromEvents)- where- enum :: [Event] -> E.Enumerator Event Maybe Document- enum e_ (E.Continue k) = k $ E.Chunks e_- enum e_ step = E.returnI step--clientListener :: Chan ClientOutEvent -> Chan InternalEvent -> Logger -> IO ()-clientListener c i l =- do event <- readChan c- logDebug l $ "clientListener: Forwarding received client event: " ++- show (event)- writeChan i (IEC event)- clientListener c i l----- TODO: Process the events that we are getting.--stateLoop :: State -> Chan InternalEvent -> Chan ClientInEvent -> Logger ->- IO ()-stateLoop s c c_ l =- do event <- readChan c- -- logDebug l $ "stateLoop: Received event: " ++ (show event)- -- TODO: Debug with state?- s' <- processEvent event- stateLoop s' c c_ l- where- -- Some readability variables.- server = stateServer s- username = stateUsername s- resource = stateResource s- password = statePassword s- handle = stateHandle s- securityState = stateSecurityState s- tlsCtx = stateTLSCtx s- isChallenge1 = stateIsChallenge1 s- isReady = stateIsReady s- - -- We are receiving a client event but are not authenticated- processEvent (IEC clientEvent) | isReady == False = do- -- As we cannot process it, we put it back in the queue- -- TODO: Ugly? Log?- writeChan c $ IEC clientEvent- return s- - -- We are receiving a client event that we should act on- processEvent (IEC clientEvent) | isReady == True = do- logDebug l $ "processEvent: Processing client event " ++- (show clientEvent)- case clientEvent of- COEDisconnect ->- -- TODO: Disconnect- return s- _ -> do- logDebug l $ "processEvent: Received Client Out Event: " ++ (show clientEvent)- let xml = clientOutEventToXML clientEvent- logDebug l $ "processEvent: Sending XML: " ++ xml- sendData (fromJust tlsCtx) $ DBLC.pack $ encodeString $ xml- return s- - -- TLS negotiation has suceeded- processEvent (IES (TLSSucceeded receivedTLSCtx)) =- return (s { stateSecurityState = TLSSecured- , stateTLSCtx = Just receivedTLSCtx } )- - -- We failed to match a security event- processEvent (IES securityEvent) = do- logWarning l $ "processEvent: Security event slipped through: " ++- (show securityEvent)- return s- - -- A <stream:stream> element has begun- -- TODO: Parse the XEStreamBegin object- processEvent (IEX (XEBeginStream _)) = do- logDebug l "processEvent: A new stream has been opened"- return s- - -- We have received <features> on an insecure stream- -- TODO: Parse the XEFeatures object- processEvent (IEX (XEFeatures _)) | securityState == NotTLSSecured = do- logDebug l $- "processEvent: Received features ([...]) on insecure stream; reque" ++- "sting \"starttls\""- hPutStr handle "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>"- hFlush handle- return s- - -- We have received <features> on an unauthenticated secure stream- processEvent (IEX (XEFeatures _)) | securityState == TLSSecured = do- logDebug l $- "processEvent: Received features ([...]) on an unauthenticated sec" ++- "ure stream; requesting to authenticate"- do sendData (fromJust tlsCtx) $ DBLC.pack $ encodeString $ getAuth- return s- - -- We have received <features> on an authenticated secure stream; we are- -- now ready to start processing client events- processEvent (IEX (XEFeatures _)) | securityState == SASLSecured = do- logDebug l $- "processEvent: Received features ([...]) on an authenticated secur" ++- "e stream"- logInfo l "processEvent: User has successfully logged in"- case resource of- Nothing -> do- return ()- _ -> do- logDebug l $ "processEvent: Setting resource: " ++- (fromJust resource)- sendData (fromJust tlsCtx) $ DBLC.pack $ encodeString- "<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:params:" ++- "xml:ns:xmpp-bind\"><resource>" ++ fromJust resource ++- "</resource></bind></iq>"- r <- getID- sendData (fromJust tlsCtx) $ DBLC.pack $ encodeString $- "<iq type=\"set\" id=\"" ++ r ++- "\"><session xmlns=\"urn:ietf:params:xml:ns:xmpp-session\"/></iq>"- return (s { stateIsReady = True })- - -- We have received a SASL challenge on a secure stream- processEvent (IEX (XEChallenge (Chal challenge)))- | securityState == TLSSecured = do- let challenge' = CBBS.decode challenge- case isChallenge1 of- True -> do- -- This is the first challenge - we need to calculate the reply- logDebug l $ "processEvent: Received initial challenge: " ++- challenge ++ " (or " ++ challenge' ++ ")"- random <- getID -- TODO: Length and content.- case replyToChallenge1 challenge' server username password random of- Left reply -> do- let reply' = (filter (/= '\n') (CBBS.encode reply))- logDebug l $ "processEvent: Sending challenge response: " ++- reply'- sendData (fromJust tlsCtx) $ DBLC.pack $ encodeString $- "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>" ++- reply' ++ "</response>"- return (s { stateIsChallenge1 = False } )- Right error -> do- putStrLn $ show error- return s- False -> do- -- This is not the first challenge; [...]- -- TODO: Can we assume "rspauth"?- logDebug l $ "processEvent: Received non-initial challenge: " ++- challenge ++ " (or " ++ challenge' ++ ")"- liftIO $ sendData (fromJust tlsCtx) $ DBLC.pack $ encodeString $- "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/>"- return s- - -- We have received a SASL "success" message over a secured connection- -- TODO: Parse the success message?- -- TODO: <?xml version='1.0'?>?- processEvent (IEX (XESuccess (Succ _))) | securityState == TLSSecured = do- logDebug l $- "processEvent: Received authentication success: [...]; restarting " ++- "stream" -- TODO- sendData (fromJust tlsCtx) $ DBLC.pack $- encodeString "<?xml version='1.0'?><stream:stream to='" ++ server ++- "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/st" ++- "reams' version='1.0'>"- return s { stateSecurityState = SASLSecured }- - -- CIEIQGet (Maybe StanzaID, Maybe JID, Maybe JID, Element) |- -- CIEIQSet (StanzaID, Maybe JID, Maybe JID, Element) |- -- CIEIQResult (StanzaID, Maybe JID, Maybe JID, Maybe Element) |- processEvent (IEX (XEIQ iqEvent))- | isReady == True = do- case iqTo iqEvent of- Nothing -> do- logDebug l $ "processEvent: Got IQ for library: " ++- (show iqEvent)- _ -> do- logDebug l $ "processEvent: Got IQ for client: " ++- (show iqEvent)- writeChan c_ $ iqToClientInEvent iqEvent- putStrLn $ "!!! - " ++ (show $ iqToClientInEvent iqEvent)- return s- - processEvent (IEX (XEPresence presenceEvent)) | isReady == True = do- let Pres (_, from, _, _, _) = presenceEvent in- case from of- Nothing -> do- logDebug l $ "processEvent: Got presence for library: " ++- (show presenceEvent)- _ -> do- logDebug l $ "processEvent: Got presence for client: " ++- (show presenceEvent)- writeChan c_ $ presenceToClientInEvent presenceEvent- return s- - -- We received an XML element that we didn't parse- processEvent (IEX xmlEvent) = do- logWarning l $ "processEvent: XML event slipped through: " ++- (show xmlEvent)- return s--iqToClientInEvent :: IQ -> ClientInEvent-iqToClientInEvent iq = case iq of- IQGet (i, f, t, e) -> CIEIQGet (fromJust i, f, t, e)- IQSet (i, f, t, e) -> CIEIQSet (fromJust i, f, t, e)- IQResult (i, f, t, e) -> CIEIQResult (fromJust i, f, t, e)--presenceToClientInEvent :: Presence -> ClientInEvent-presenceToClientInEvent (Pres (i, f, t, p, e)) = CIEPresence (i, f, t, p, e)--iqTo :: IQ -> Maybe JID-iqTo (IQGet (_, j, _, _)) = j-iqTo (IQSet (_, j, _, _)) = j-iqTo (IQResult (_, j, _, _)) = j------ =============================================================================--- SASL Authentication--- =============================================================================---data Challenge1Error = C1MultipleCriticalAttributes |- C1NotAllParametersPresent |- C1SomeParamtersPresentMoreThanOnce |- C1WrongRealm |- C1UnsupportedAlgorithm |- C1UnsupportedCharset |- C1UnsupportedQOP- deriving Show----- Will produce a list of key-value pairs given a string in the format of--- realm="somerealm",nonce="OA6MG9tEQGm2hh",qop="auth",charset=utf-8...-stringToList :: String -> [(String, String)]-stringToList "" = []-stringToList s' = let (next, rest) = break' s' ','- in break' next '=' : stringToList rest- where- -- Like break, but will remove the first char of the continuation, if- -- present.- break' :: String -> Char -> (String, String)- break' s' c = let (first, second) = break ((==) c) s'- in (first, removeCharIfPresent second c)- - -- Removes the first character, if present; "=hello" with '=' becomes- -- "hello".- removeCharIfPresent :: String -> Char -> String- removeCharIfPresent [] _ = []- removeCharIfPresent (c:t) c' | c == c' = t- removeCharIfPresent s' c = s'---- Counts the number of directives in the pair list.-countDirectives :: String -> [(String, String)] -> Int-countDirectives v l = DL.length $ filter (isEntry v) l- where- isEntry :: String -> (String, String) -> Bool- isEntry name (name', _) | name == name' = True- | otherwise = False----- Returns the given directive in the list of pairs, or Nothing.-lookupDirective :: String -> [(String, String)] -> Maybe String-lookupDirective d [] = Nothing-lookupDirective d ((d', v):t) | d == d' = Just v- | otherwise = lookupDirective d t----- Returns the given directive in the list of pairs, or the default value--- otherwise.-lookupDirectiveWithDefault :: String -> [(String, String)] -> String -> String-lookupDirectiveWithDefault di l de- | lookup == Nothing = de- | otherwise = let Just r = lookup in r- where- lookup = lookupDirective di l----- TODO: Make appropriate response.--- TODO: Can it contain newline characters?---- Takes a challenge string (which is not Base64-encoded), the host name of the--- Jabber server, the Jabber user name (JID), the password and a random and--- unique "cnonce" value and generates either an error or a response to that--- challenge.------ TODO: Host is assumed to be ISO 8859-1; make list of assumptions.---- We have broken replyToChallenge1 for non-TLS authentication. In order to--- change it back, just uncomment the lines relevant to the realm and match it--- in the C1NotAllParametersSet case.--replyToChallenge1 :: String -> String -> String -> String -> String ->- Either String Challenge1Error-replyToChallenge1 s h u p c =- -- Remove all new line characters.- let list = stringToList $ filter (/= '\n') s- in -- Count that there are no more than one nonce or algorithm directives.- case countDirectives "nonce" list <= 1 &&- countDirectives "algorithm" list <= 1 of- True ->- let -- realm = lookupDirective "realm" list- nonce = lookupDirective "nonce" list- qop = lookupDirectiveWithDefault "qop" list "auth"- charset = lookupDirectiveWithDefault "charset" list "utf-8"- algorithm = lookupDirective "algorithm" list- - -- Verify that all necessary directives has been set.- in case (nonce, qop, charset, algorithm) of- (Just nonce', qop', charset', Just algorithm') ->- - -- Strip quotations of the directives that need it.- let -- realm'' = stripQuotations realm'- nonce'' = stripQuotations nonce'- qop'' = stripQuotations qop' -- It seems ejabberd gives us an errorous "auth" instead of auth- in- -- -- Verify that the realm is the same as the Jabber host.- -- case realm'' == h of- -- True ->- - -- Verify that QOP is "auth", charset is "utf-8" and that- -- the algorithm is "md5-sess".- case qop'' == "auth" of- True ->- case charset' == "utf-8" of- True ->- case algorithm' == "md5-sess" of- True ->- - -- All data is valid; generate the reply.- Left (reply nonce'' qop'')- - -- Errors are caught and reported below.- False -> Right C1UnsupportedAlgorithm- False -> Right C1UnsupportedCharset- False -> Right C1UnsupportedQOP- -- False -> Right C1WrongRealm- _ -> Right C1NotAllParametersPresent- where- reply n q =- let -- We start with what's in RFC 2831 is referred to as "A1", a 16 octet- -- MD5 hash.- - -- If the username or password values are in ISO-8859-1, we convert- -- them to ISO-8859-1 strings.- username = case all isLatin1 u of- True -> DBL.pack $ map c2w u- False -> DBLC.pack $ u- password = case all isLatin1 p of- True -> DBL.pack $ map c2w p- False -> DBLC.pack p- - nc = "00000001"- digestUri = "xmpp/" ++ h- - -- Build the "{ username-value, ":", realm-value, ":", passwd }"- -- bytestring, the rest of the bytestring and then join them.- a1a = DBi.encode $ md5 $ DBLC.append- (DBLC.append username (DBLC.pack (":" ++ h ++ ":")))- password- a1aDebug = "DBi.encode $ md5 $ " ++ (DBLC.unpack $ DBLC.append- (DBLC.append username (DBLC.pack (":" ++ h ++ ":")))- password)- a1b = DBLC.pack (":" ++ n ++ ":" ++ c)- a1 = DBLC.append a1a a1b- - -- Generate the "A2" value.- a2 = DBLC.pack ("AUTHENTICATE:" ++ digestUri)- - -- Produce the responseValue.- k = DBLC.pack (show $ md5 a1)- colon = DBLC.pack ":"- s0 = DBLC.pack (n ++ ":" ++ nc ++ ":" ++ c ++ ":" ++- q ++ ":")- s1 = DBLC.pack $ show $ md5 a2- - s_ = DBLC.append s0 s1- -- append k:d and 16 octet hash it- kd = md5 (DBLC.append k (DBLC.append colon s_))- - lol0 = DBLC.unpack s_- lol1 = show kd- - response = show kd- in "username=\"" ++ u ++ "\",realm=\"" ++ h ++ "\",nonce=\"" ++ n ++- "\",cnonce=\"" ++ c ++ "\",nc=" ++ nc ++ ",digest-uri=\"" ++- digestUri ++ "\",qop=auth,response=" ++ response ++ ",charset=utf-8"- -- "\n\n" ++- -- "a1aDebug: " ++ a1aDebug ++ "\n" ++- -- "a1b: " ++ (DBLC.unpack a1b) ++ "\n" ++- -- "a1: " ++ (DBLC.unpack a1) ++ "\n" ++- -- "a2: " ++ (DBLC.unpack a2) ++ "\n" ++- -- "k: " ++ (DBLC.unpack k) ++ "\n" ++- -- "colon: " ++ (DBLC.unpack colon) ++ "\n" ++- -- "s0: " ++ (DBLC.unpack s0) ++ "\n" ++- -- "s1: " ++ (DBLC.unpack s1) ++ "\n" ++- -- "s_: " ++ (DBLC.unpack s_) ++ "\n"----- Stripts the quotations around a string, if any; "\"hello\"" becomes "hello".--stripQuotations :: String -> String-stripQuotations "" = ""-stripQuotations s | (head s == '"') && (last s == '"') = tail $ init s- | otherwise = s------ =============================================================================--- Temporary--- =============================================================================----- either = from/to-data Subscription = SSubscribe { subscribeSource :: Either JID JID } |- SUnsubscribe { unsubscribeSource :: Either JID JID } |- SSubscribed { subscribedSource :: Either JID JID } |- SUnsubscribed { unsubscribedSource :: Either JID JID }--data IQ = IQGet (Maybe StanzaID, Maybe JID, Maybe JID, Element) |- IQSet (Maybe StanzaID, Maybe JID, Maybe JID, Element) |- IQResult (Maybe StanzaID, Maybe JID, Maybe JID, Maybe Element) deriving (Eq, Show)--data Presence = Pres (Maybe StanzaID, Maybe JID, Maybe JID, Maybe PresenceType, [Element]) deriving (Eq, Show)---- | The iqErrorAppPayload field is used in conjuction with--- UndefinedCondition.--data IQError = IQError { iqErrorID :: StanzaID- , iqErrorFrom :: JID- -- , iqErrorTo :: JID- , iqErrorPayload :: Element- , iqErrorAppPayload :: Maybe Element- , iqErrorType :: StanzaErrorType- , iqErrorCondition :: StanzaErrorCondition } deriving (Eq, Show)--getAuth = "<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='DIGEST-MD5'/>"---- ----------------------------------------------------------------------------data ParsingContext = PreDocument -- No xml stream received- | Authenticating -- Received xml stream and negotiate for- -- stream features- | Challenge -- Send Challenge to server and recieve..- | Authenticated -- Conected to Jabber server- | Disconnected -- Disconected to Jabber server- deriving Eq--data State = State { stateServer :: String- , statePort :: Integer- , stateUsername :: String- , stateResource :: Maybe String- , statePassword :: String- , stateHandle :: Handle- , stateStreamID :: Maybe String- , stateSecurityState :: SecurityState- , stateTLSCtx :: (Maybe TLSCtx)- , stateIsChallenge1 :: Bool- , stateIsReady :: Bool } -- Ready for client events--defaultState s po u r pa h = State { stateServer = s- , statePort = po- , stateUsername = u- , stateResource = r- , statePassword = pa- , stateHandle = h- , stateStreamID = Nothing- , stateSecurityState = NotTLSSecured- , stateTLSCtx = Nothing- , stateIsChallenge1 = True- , stateIsReady = False }--myEnum :: (Monad m) => [Event] -> E.Enumerator Event m Document-myEnum es (E.Continue k) = k $ E.Chunks es-myEnum es step = E.returnI step--procDoc :: Iteratee Document IO ()-procDoc = do- -- case h of- -- Just e -> liftIO $ putStrLn " Got an Element : " ++ show e- -- Nothing -> liftIO $ putStrLn " Got no Element "- procDoc---- Return a list of Event or empty list-toList :: (Maybe Event) -> [Event]-toList (Just e) = [e]-toList Nothing = []--counter :: Int -> Maybe Event -> Int-counter c (Just (EventBeginElement _ _)) = (c + 1)-counter c (Just (EventEndElement _) ) = (c - 1)-counter c _ = c---- Just prints the Events-callEvent :: [Event] -> IO ()-callEvent [] = putStrLn "End of the document...."-callEvent (x:xs) = do- putStrLn $ show x -- for test- callEvent xs--printFeatures :: [Event] -> IO ()-printFeatures [] = do- putStrLn "End of my Events *****************************"- return ()-printFeatures (e:es) = do- putStrLn "******************************************************************"- putStrLn $ show e- printFeatures es- return ()--- Try to authenticate bas on features list-authenticating :: Features -> Bool-authenticating f = True--getFeatures :: Features -> [Event] -> Features-getFeatures f [] = f--- TODO: Check for the server offered features.-getFeatures f es = getFeatures (f { featuresStartTLS = True }) []---getFeatures' :: [Event] -> IO ()-getFeatures' es = do- d <- eventsToDoc es- let r = documentRoot d- putStrLn $ show r- return ()---- Convert a list of Events to a Document-eventsToDoc :: [Event] -> IO Document-eventsToDoc es = do- run_ $ myEnum es $$ fromEvents---- TODO: Actually parse the element.-getSF :: Element -> Features-getSF _ = Features { featuresStartTLS = False- , featuresMechanisms = [DigestMD5]- , featuresCompressionMethods = [Zlib] }--parseIQ :: Element -> IQ-parseIQ e | typeAttr == "get" = let (Just payloadMust) = payload- in (IQGet (idAttr,- fromAttr,- toAttr,- payloadMust))- | typeAttr == "set" = let (Just payloadMust) = payload- in (IQSet (idAttr,- fromAttr,- toAttr,- payloadMust))- | typeAttr == "result" = IQResult (idAttr,- fromAttr,- toAttr,- payload)- where- -- TODO: Many duplicate functions from parsePresence.- - payload :: Maybe Element- payload = case null (elementChildren e) of- True -> Nothing- False -> Just $ head $ elementChildren e- - typeAttr :: String- typeAttr = case attributeText typeName e of- -- Nothing -> Nothing- Just a -> DT.unpack a- - fromAttr :: Maybe JID- fromAttr = case attributeText fromName e of- Nothing -> Nothing- Just a -> stringToJID $ DT.unpack a- - toAttr :: Maybe JID- toAttr = case attributeText toName e of- Nothing -> Nothing- Just a -> stringToJID $ DT.unpack a- - idAttr :: Maybe StanzaID- idAttr = case attributeText idName e of- Nothing -> Nothing- Just a -> Just (SID (DT.unpack a))- - typeName :: Name- typeName = fromString "type"- - fromName :: Name- fromName = fromString "from"- - toName :: Name- toName = fromString "to"- - idName :: Name- idName = fromString "id"--parsePresence :: Element -> Presence-parsePresence e = Pres (idAttr, fromAttr, toAttr, typeAttr, elementChildren e)- where- -- TODO: Many duplicate functions from parseIQ.- - typeAttr :: Maybe PresenceType- typeAttr = case attributeText typeName e of- Just t -> Just (presence $ DT.unpack t)- Nothing -> Nothing- - fromAttr :: Maybe JID- fromAttr = case attributeText fromName e of- Nothing -> Nothing- Just a -> stringToJID $ DT.unpack a- - toAttr :: Maybe JID- toAttr = case attributeText toName e of- Nothing -> Nothing- Just a -> stringToJID $ DT.unpack a- - idAttr :: Maybe StanzaID- idAttr = case attributeText idName e of- Nothing -> Nothing- Just a -> Just (SID (DT.unpack a))- - fromName :: Name- fromName = fromString "from"- - typeName :: Name- typeName = fromString "type"- - toName :: Name- toName = fromString "to"- - idName :: Name- idName = fromString "id"--presence "available" = Available-presence "away" = Away-presence "chat" = Chat-presence "dnd" = DoNotDisturb-presence "xa" = ExtendedAway--presence "probe" = Probe--presence "unavailable" = Unavailable-presence "subscribe" = Subscribe-presence "subscribed" = Subscribed-presence "unsubscribe" = Unsubscribe-presence "unsubscribed" = Unsubscribed--presence_ Available = "available"-presence_ Away = "away"-presence_ Chat = "chat"-presence_ DoNotDisturb = "dnd"-presence_ ExtendedAway = "xa"-presence_ Unavailable = "unavailable"--presence_ Probe = "probe"--presence_ Subscribe = "subscribe"-presence_ Subscribed = "subscribed"-presence_ Unsubscribe = "unsubscribe"-presence_ Unsubscribed = "unsubscribed"--clientOutEventToXML :: ClientOutEvent -> String-clientOutEventToXML (COESimplePresence (presenceType, Nothing)) =- "<presence><priority>5</priority><show>" ++ (presence_ presenceType) ++ "</show></presence>"-clientOutEventToXML (COESimplePresence (presenceType, Just (PS status))) =- "<presence><priority>5</priority><show>" ++ (presence_ presenceType) ++ "</show><status>" ++ status ++ "</status></presence>"-clientOutEventToXML (COEComplexPresence (t, s, e)) =- "<presence" ++ t' ++ s' ++ ">" ++ (e' e) ++ "</presence>"- where- e' :: Maybe Element -> String- e' e = case e of- Nothing -> ""- Just e_ -> DT.unpack $ head $ elementText e_ -- TODO- s' :: String- s' = case s of- -- TODO: Lower-case- Just s'' -> " type='" ++ (presence_ s'') ++ "'"- Nothing -> ""- t' :: String- t' = case t of- Just t'' -> " to='" ++ (jidToString t'') ++ "'"-clientOutEventToXML (COEIQGet (s, j, e)) = "<iq type='get'" ++ s' ++ j' ++ ">" ++ (elementToString $ Just e) ++ "</iq>"- where- s' = case s of- Nothing -> ""- Just (SID i) -> " id=\"" ++ i ++ "\""- j' = case j of- Nothing -> ""- Just t -> " to=\"" ++ (jidToString t) ++ "\""--clientOutEventToXML (COEIQSet (s, j, e)) = "<iq type='set'" ++ s' ++ j' ++ ">" ++ (elementToString $ Just e) ++ "</iq>"- where- s' = case s of- Nothing -> ""- Just (SID i) -> " id=\"" ++ i ++ "\""- j' = case j of- Nothing -> ""- Just t -> " to=\"" ++ (jidToString t) ++ "\""--clientOutEventToXML (COEIQResult (s, j, e)) = "<iq type='result'" ++ s' ++ j' ++ ">" ++ (elementToString e) ++ "</iq>"- where- s' = case s of- Nothing -> ""- Just (SID i) -> " id=\"" ++ i ++ "\""- j' = " to=\"" ++ (jidToString j) ++ "\""--elementToString :: Maybe Element -> String-elementToString Nothing = ""-elementToString (Just e) = "<" ++ nameToString (elementName e) ++ xmlns ++- attributes (DM.toList (elementAttributes e)) ++ ">" ++- (nodesToString $ elementNodes e) ++ "</" ++- nameToString (elementName e) ++ ">"- where- xmlns :: String- xmlns = case nameNamespace $ elementName e of- Nothing -> ""- Just t -> " xmlns='" ++ (DT.unpack t) ++ "'"- - nameToString :: Name -> String- nameToString Name { nameLocalName = n, namePrefix = Nothing } = DT.unpack n- nameToString Name { nameLocalName = n, namePrefix = Just p } = (DT.unpack p) ++ ":" ++ (DT.unpack n)-- contentToString :: Content -> String- contentToString (ContentText t) = DT.unpack t- contentToString (ContentEntity t) = DT.unpack t- - attributes :: [(Name, [Content])] -> String- attributes [] = ""- attributes ((n, c):t) = (" " ++ (nameToString n) ++ "='" ++- concat (map contentToString c) ++ "'") ++- attributes t- - nodesToString :: [Node] -> String- nodesToString [] = ""- nodesToString ((NodeElement e):ns) = (elementToString $ Just e) ++ (nodesToString ns)- nodesToString ((NodeContent c):ns) = (contentToString c) ++ (nodesToString ns)
+ Network/XMPP/SASL.hs view
@@ -0,0 +1,194 @@+-- TODO: Make it possible to include host.+-- TODO: Host is assumed to be ISO 8859-1; make list of assumptions.+-- TODO: Can it contain newline characters?++module Network.XMPP.SASL (replyToChallenge1) where++import Data.ByteString.Internal (c2w)+import Data.Char (isLatin1)+import Data.Digest.Pure.MD5+import qualified Data.Binary as DBi (Binary, encode)+import qualified Data.ByteString.Lazy as DBL (ByteString, append, pack,+ fromChunks, toChunks, null)+import qualified Data.ByteString.Lazy.Char8 as DBLC (append, pack, unpack)+import qualified Data.List as DL+++data Challenge1Error = C1MultipleCriticalAttributes |+ C1NotAllParametersPresent |+ C1SomeParamtersPresentMoreThanOnce |+ C1WrongRealm |+ C1UnsupportedAlgorithm |+ C1UnsupportedCharset |+ C1UnsupportedQOP+ deriving Show+++-- Will produce a list of key-value pairs given a string in the format of+-- realm="somerealm",nonce="OA6MG9tEQGm2hh",qop="auth",charset=utf-8...+stringToList :: String -> [(String, String)]+stringToList "" = []+stringToList s' = let (next, rest) = break' s' ','+ in break' next '=' : stringToList rest+ where+ -- Like break, but will remove the first char of the continuation, if+ -- present.+ break' :: String -> Char -> (String, String)+ break' s' c = let (first, second) = break ((==) c) s'+ in (first, removeCharIfPresent second c)+ + -- Removes the first character, if present; "=hello" with '=' becomes+ -- "hello".+ removeCharIfPresent :: String -> Char -> String+ removeCharIfPresent [] _ = []+ removeCharIfPresent (c:t) c' | c == c' = t+ removeCharIfPresent s' c = s'++-- Counts the number of directives in the pair list.+countDirectives :: String -> [(String, String)] -> Int+countDirectives v l = DL.length $ filter (isEntry v) l+ where+ isEntry :: String -> (String, String) -> Bool+ isEntry name (name', _) | name == name' = True+ | otherwise = False+++-- Returns the given directive in the list of pairs, or Nothing.+lookupDirective :: String -> [(String, String)] -> Maybe String+lookupDirective d [] = Nothing+lookupDirective d ((d', v):t) | d == d' = Just v+ | otherwise = lookupDirective d t+++-- Returns the given directive in the list of pairs, or the default value+-- otherwise.+lookupDirectiveWithDefault :: String -> [(String, String)] -> String -> String+lookupDirectiveWithDefault di l de+ | lookup == Nothing = de+ | otherwise = let Just r = lookup in r+ where+ lookup = lookupDirective di l+++-- Takes a challenge string (which is not Base64-encoded), the host name of the+-- Jabber server, the Jabber user name (JID), the password and a random and+-- unique "cnonce" value and generates either an error or a response to that+-- challenge.++-- We have broken replyToChallenge1 for non-TLS authentication. In order to+-- change it back, just uncomment the lines relevant to the realm and match it+-- in the C1NotAllParametersSet case.++replyToChallenge1 :: String -> String -> String -> String -> String ->+ Either String Challenge1Error+replyToChallenge1 s h u p c =+ -- Remove all new line characters.+ let list = stringToList $ filter (/= '\n') s+ in -- Count that there are no more than one nonce or algorithm directives.+ case countDirectives "nonce" list <= 1 &&+ countDirectives "algorithm" list <= 1 of+ True ->+ let -- realm = lookupDirective "realm" list+ nonce = lookupDirective "nonce" list+ qop = lookupDirectiveWithDefault "qop" list "auth"+ charset = lookupDirectiveWithDefault "charset" list "utf-8"+ algorithm = lookupDirective "algorithm" list+ + -- Verify that all necessary directives has been set.+ in case (nonce, qop, charset, algorithm) of+ (Just nonce', qop', charset', Just algorithm') ->+ + -- Strip quotations of the directives that need it.+ let -- realm'' = stripQuotations realm'+ nonce'' = stripQuotations nonce'+ qop'' = stripQuotations qop' -- It seems ejabberd gives us an errorous "auth" instead of auth+ in+ -- -- Verify that the realm is the same as the Jabber host.+ -- case realm'' == h of+ -- True ->+ + -- Verify that QOP is "auth", charset is "utf-8" and that+ -- the algorithm is "md5-sess".+ case qop'' == "auth" of+ True ->+ case charset' == "utf-8" of+ True ->+ case algorithm' == "md5-sess" of+ True ->+ + -- All data is valid; generate the reply.+ Left (reply nonce'' qop'')+ + -- Errors are caught and reported below.+ False -> Right C1UnsupportedAlgorithm+ False -> Right C1UnsupportedCharset+ False -> Right C1UnsupportedQOP+ -- False -> Right C1WrongRealm+ _ -> Right C1NotAllParametersPresent+ where+ reply n q =+ let -- We start with what's in RFC 2831 is referred to as "A1", a 16 octet+ -- MD5 hash.+ + -- If the username or password values are in ISO-8859-1, we convert+ -- them to ISO-8859-1 strings.+ username = case all isLatin1 u of+ True -> DBL.pack $ map c2w u+ False -> DBLC.pack $ u+ password = case all isLatin1 p of+ True -> DBL.pack $ map c2w p+ False -> DBLC.pack p+ + nc = "00000001"+ digestUri = "xmpp/" ++ h+ + -- Build the "{ username-value, ":", realm-value, ":", passwd }"+ -- bytestring, the rest of the bytestring and then join them.+ a1a = DBi.encode $ md5 $ DBLC.append+ (DBLC.append username (DBLC.pack (":" ++ h ++ ":")))+ password+ a1aDebug = "DBi.encode $ md5 $ " ++ (DBLC.unpack $ DBLC.append+ (DBLC.append username (DBLC.pack (":" ++ h ++ ":")))+ password)+ a1b = DBLC.pack (":" ++ n ++ ":" ++ c)+ a1 = DBLC.append a1a a1b+ + -- Generate the "A2" value.+ a2 = DBLC.pack ("AUTHENTICATE:" ++ digestUri)+ + -- Produce the responseValue.+ k = DBLC.pack (show $ md5 a1)+ colon = DBLC.pack ":"+ s0 = DBLC.pack (n ++ ":" ++ nc ++ ":" ++ c ++ ":" +++ q ++ ":")+ s1 = DBLC.pack $ show $ md5 a2+ + s_ = DBLC.append s0 s1+ -- append k:d and 16 octet hash it+ kd = md5 (DBLC.append k (DBLC.append colon s_))+ + lol0 = DBLC.unpack s_+ lol1 = show kd+ + response = show kd+ in "username=\"" ++ u ++ "\",realm=\"" ++ h ++ "\",nonce=\"" ++ n +++ "\",cnonce=\"" ++ c ++ "\",nc=" ++ nc ++ ",digest-uri=\"" +++ digestUri ++ "\",qop=auth,response=" ++ response ++ ",charset=utf-8"+ -- "\n\n" +++ -- "a1aDebug: " ++ a1aDebug ++ "\n" +++ -- "a1b: " ++ (DBLC.unpack a1b) ++ "\n" +++ -- "a1: " ++ (DBLC.unpack a1) ++ "\n" +++ -- "a2: " ++ (DBLC.unpack a2) ++ "\n" +++ -- "k: " ++ (DBLC.unpack k) ++ "\n" +++ -- "colon: " ++ (DBLC.unpack colon) ++ "\n" +++ -- "s0: " ++ (DBLC.unpack s0) ++ "\n" +++ -- "s1: " ++ (DBLC.unpack s1) ++ "\n" +++ -- "s_: " ++ (DBLC.unpack s_) ++ "\n"+++-- Stripts the quotations around a string, if any; "\"hello\"" becomes "hello".++stripQuotations :: String -> String+stripQuotations "" = ""+stripQuotations s | (head s == '"') && (last s == '"') = tail $ init s+ | otherwise = s
+ Network/XMPP/Session.hs view
@@ -0,0 +1,906 @@+-- | Module: $Header$+-- Description: XMPP client session management module+-- Copyright: Copyright © 2010-2011 Jon Kristensen+-- License: BSD-3+-- +-- Maintainer: info@pontarius.org+-- Stability: unstable+-- Portability: portable+-- +-- This module will be documented soon.++-- TODO: Send white-space characters with regular intervals to keep the+-- connection alive.+-- TODO: Add namespace support for stream/features?+-- TODO: Add support for `ver optional' support for features?+-- TODO: Presence priority?+-- TODO: Stop the logger+-- TODO: Catch errors++module Network.XMPP.Session ( XMPPInEvent (..)+ , XMPPOutEvent (..)+ , createSession ) where+++import Network.XMPP.JID+import Network.XMPP.SASL+import Network.XMPP.Stanza+import Network.XMPP.Utilities++import Codec.Binary.UTF8.String+import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)+import Control.Concurrent (forkIO, threadDelay)+import Control.Monad.IO.Class (liftIO, MonadIO)+import Data.Enumerator (($$), Iteratee, continue, joinI,+ run_, yield)+import Data.Enumerator.Binary (enumHandle, enumFile)+import Data.Maybe+import Data.String+import Data.XML.Types+import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput)+import Network+import Network.TLS+import Network.TLS.Cipher+import System.IO (BufferMode, BufferMode(NoBuffering))+import System.Log.HLogger+import System.Log.SimpleHLogger+import Text.XML.Enumerator.Parse (parseBytes, decodeEntities)+import Text.XML.Enumerator.Document (fromEvents)+import qualified Codec.Binary.Base64.String as CBBS+import qualified Data.ByteString as DB+import qualified Data.ByteString.Lazy as DBL (ByteString, append, pack, fromChunks, toChunks, null)+import qualified Data.ByteString.Lazy.Char8 as DBLC (append, pack, unpack)+import qualified Data.Enumerator as E+import qualified Data.Enumerator.List as EL+import qualified Data.List as DL+import qualified Data.Text as DT+import qualified Data.Text.Lazy as DTL+++type Server = String+type Port = Integer++type UserName = String+type Password = String+type Resource = String+++data XMPPInEvent = XIEConnectionSucceeded |+ XIEConnectionFailed |+ XIEAuthenticationSucceeded |+ XIEAuthenticationFailed |+ XIEMessage Message |+ XIEPresence Presence |+ XIEIQ IQ |+ -- XIEIQJingle | -- Added for Jingle sessions+ -- XIEIQXTLS | -- Added for XTLS connection+ XIEDisconnect deriving (Eq, Show)++data XMPPOutEvent = XOEConnect Server Port |+ XOEAuthenticate UserName Password Resource |+ XOEMessage Message |+ XOEPresence Presence |+ XOEIQ IQ |+ -- XOEIQJingle | -- Added for Jingle sessions+ -- XOEIQXTLS | -- Added for XTLS connection+ XOEDisconnect deriving (Eq, Show)+++data SecurityEvent = TLSSucceeded TLSCtx | TLSFailed+++instance Show SecurityEvent where+ show (TLSSucceeded _) = "TLSSucceeded Ctx"+ show TLSFailed = "TLSFailed"+++data ConnectionState = Disconnected |+ ConnectedNotTLSSecured |+ ConnectedTLSSecured TLSCtx++instance Eq ConnectionState where+ (==) Disconnected Disconnected = True+ (==) ConnectedNotTLSSecured ConnectedNotTLSSecured = True+ (==) (ConnectedTLSSecured _) (ConnectedTLSSecured _) = True+ (==) _ _ = False++data AuthenticationState = AuthNotRequested |+ AuthRequested |+ Challenge1Processed |+ Authenticated deriving (Eq)++data State = State { stateConnectionState :: ConnectionState+ , stateAuthenticationState :: AuthenticationState+ , stateHandle :: Maybe Handle+ , stateServer :: Maybe (Server, Port)+ , stateUserName :: Maybe String+ , statePassword :: Maybe String+ , stateResource :: Maybe String+ , stateStreamID :: Maybe String }++defaultState = State { stateConnectionState = Disconnected+ , stateAuthenticationState = AuthNotRequested+ , stateHandle = Nothing+ , stateServer = Nothing+ , stateUserName = Nothing+ , statePassword = Nothing+ , stateResource = Nothing+ , stateStreamID = Nothing }+++-- An XMLEvent is a high-level XMPP event generated by our XML parsing code.++data XMLEvent = XEBeginStream Stream | XEFeatures Features |+ XEChallenge Challenge | XESuccess Success |+ XEEndStream | XEIQ IQ | XEPresence Presence |+ XEMessage Message | XEOther String deriving (Show)+++-- Represents the top-level "<stream>" element.++data Stream = Stream { streamNamespace :: StreamNamespace+ , streamID :: String+ , streamVersion :: Float } deriving (Show)+++-- TODO: Do not make this assumption, but parse the element instead.++defaultStream id = Stream { streamNamespace = Client+ , streamID = id+ , streamVersion = 1.0 }+++-- The "<stream:features>" element.++data Features = Features { featuresStartTLS :: Bool+ , featuresMechanisms :: [FeaturesMechanism]+ , featuresCompressionMethods :: [CompressionMethod] } deriving (Show)+++-- TODO: Do not make this assumption, but parse the element instead.++featuresDefault = Features { featuresStartTLS = True,+ featuresMechanisms = [DigestMD5],+ featuresCompressionMethods = [] }+++-- TODO: Necessary?++data StreamNamespace = Client | Server deriving (Show)+++-- Authentication mechanisms. We only support DigestMD5 at this point.++data FeaturesMechanism = DigestMD5 | CramMD5 | Login | Plain | UnknownMechanism deriving (Show)++data UnknownMechanism = UM String deriving (Show)+++data CompressionMethod = Zlib deriving (Show)+++-- Containers for information from SASL challenges and successes.++data Challenge = Chal String deriving (Show)++data Success = Succ String deriving (Show)+++data InternalEvent = IEX XMLEvent |+ IEO XMPPOutEvent |+ IES SecurityEvent deriving (Show)+++-- | Creates a Pontarius XMPP session by setting up internal processes and state+-- and creates the two (in and out) event channels that the XMPP client uses+-- for communicating with Pontarius XMPP.++createSession :: IO (Chan XMPPInEvent, Chan XMPPOutEvent)++createSession = do+ logger <- simpleLogger "PontariusXMPP"+ loggerLog logger (Just ("Session", "createSession")) Info "Pontarius XMPP has started"+ + -- Create client "in" and "out" channels (naming from the perspective of the+ -- XMPP client) as well as the internal event channel used by the state loop+ inChan <- newChan+ outChan <- newChan+ internalChan <- newChan+ + -- Start to listen to client "out" events (client actions)+ forkIO $ clientListener outChan internalChan logger+ + -- Start the state loop, the main loop of Pontarius XMPP+ forkIO $ stateLoop defaultState internalChan inChan logger+ + return (inChan, outChan)+++-- Receives events from the XMPP client and forwards them to the state loop by+-- using the internal event channel.++clientListener :: Chan XMPPOutEvent -> Chan InternalEvent -> Logger -> IO ()++clientListener c c_ l =+ do event <- readChan c+ loggerLog l (Just ("Session", "clientListener")) Debug $ "clientListener: Forwarding received client event: " ++ show (event)+ writeChan c_ (IEO event)+ clientListener c c_ l+++-- Processes internal events to possibly perform actions and update the session+-- state. Note that the InternalEvent type wraps the external client events.++stateLoop :: State -> Chan InternalEvent -> Chan XMPPInEvent -> Logger -> IO ()++stateLoop s c c_ l =+ do event <- readChan c+ -- logDebug l $ "stateLoop: Received event: " ++ (show event)+ -- TODO: Debug with state?+ s' <- processEvent event+ stateLoop s' c c_ l+ where+ connectionState = stateConnectionState s+ authenticationState = stateAuthenticationState s+ handle = stateHandle s+ server = stateServer s+ userName = stateUserName s+ password = statePassword s+ resource = stateResource s+ streamID = stateStreamID s+ Just (serverHost, serverPort) = stateServer s+ tlsCtx = let ConnectedTLSSecured x = connectionState in x+ + -- let xml = clientOutEventToXML clientEvent+ -- logDebug l $ "processEvent: Sending XML: " ++ xml+ -- sendData (fromJust tlsCtx) $ DBLC.pack $ encodeString $ xml+ + processEvent (IEO clientOutEvent) = do+ loggerLog l (Just ("Session", "processEvent")) Debug $ "Processing client out event " ++ (show clientOutEvent)+ case clientOutEvent of+ XOEConnect serverHost_ serverPort_ -> do+ handle <- connectTo serverHost_ (PortNumber $ fromInteger serverPort_)+ hSetBuffering handle NoBuffering+ hPutStr handle $ encodeString $+ "<?xml version='1.0'?><stream:stream to='" ++ serverHost_ +++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.or" +++ "g/streams' version='1.0'>"+ hFlush handle+ + -- Start XML enumerator, which will read from the handle to generate the+ -- relevant internal events+ forkIO $ xmlEnumerator c handle serverHost_ l+ + return s { stateConnectionState = ConnectedNotTLSSecured+ , stateHandle = Just handle+ , stateServer = Just (serverHost_, serverPort_) }+ + -- TODO: Function to verify certificate?+ XOEAuthenticate userName_ password_ resource_ -> do+ sendData tlsCtx $ DBLC.pack $ encodeString+ "<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='DIGEST-MD5'/>"+ return s { stateAuthenticationState = AuthRequested+ , stateUserName = Just userName_+ , statePassword = Just password_+ , stateResource = Just resource_ }+ + XOEPresence presence -> do+ presence' <- case stanzaID $ presenceStanza presence of+ Nothing -> do+ id <- getID+ return $ presence { presenceStanza = (presenceStanza presence) { stanzaID = Just (SID id) } }+ _ -> return presence+ + let xml = presenceToXML presence'+ loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Will send presence XML: " ++ xml+ sendData tlsCtx $ DBLC.pack $ encodeString $ xml+ return s+ + XOEMessage message -> do+ message' <- case stanzaID $ messageStanza message of+ Nothing -> do+ id <- getID+ return $ message { messageStanza = (messageStanza message) { stanzaID = Just (SID id) } }+ _ -> return message+ + let xml = messageToXML message'+ loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Will send message XML: " ++ xml+ sendData tlsCtx $ DBLC.pack $ encodeString $ xml+ return s+ + XOEIQ iq -> do+ iq' <- case stanzaID $ iqStanza iq of+ Nothing -> do+ id <- getID+ 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) } }+ _ -> return iq+ + let xml = iqToXML iq'+ loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Will send IQ XML: " ++ xml+ sendData tlsCtx $ DBLC.pack $ encodeString $ xml+ return s+ + XOEDisconnect -> do+ -- TODO: Close stream+ return s+ + -- TODO: processEvent (IES TLSFailed) =+ + processEvent (IES (TLSSucceeded receivedTLSCtx)) =+ return (s { stateConnectionState = ConnectedTLSSecured receivedTLSCtx })+ + -- A <stream:stream> element has begun+ -- TODO: Parse the XEStreamBegin object+ processEvent (IEX (XEBeginStream _)) = do+ loggerLog l (Just ("Session", "processEvent")) Debug "processEvent: A new stream has been opened"+ return s+ + -- We have received <features> on an insecure stream+ -- TODO: Parse the XEFeatures object+ processEvent (IEX (XEFeatures _))+ | connectionState == ConnectedNotTLSSecured = do+ loggerLog l (Just ("Session", "processEvent")) Debug $+ "processEvent: Received features ([...]) on insecure stream; req" +++ "uesting \"starttls\""+ hPutStr (fromJust handle) $+ "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>"+ hFlush (fromJust handle)+ return s+ + -- We have received <features> on a secure and non-authenticated stream+ processEvent (IEX (XEFeatures _))+ | connectionState == ConnectedTLSSecured tlsCtx &&+ authenticationState /= Authenticated = do+ loggerLog l (Just ("Session", "processEvent")) Debug $+ "processEvent: Received features ([...]) on an unauthenticated" +++ " secure stream"+ writeChan c_ $ XIEConnectionSucceeded+ return s+ + -- We have received <features> on an authenticated secure stream; we are+ -- now ready to start processing client events+ processEvent (IEX (XEFeatures _))+ | connectionState == ConnectedTLSSecured tlsCtx = do+ loggerLog l (Just ("Session", "processEvent")) Debug $+ "processEvent: Received features ([...]) on an authenticated sec" +++ "ure stream"+ loggerLog l (Just ("Session", "processEvent")) Info $ "processEvent: User has successfully logged in"+ case resource of+ Nothing -> do+ sendData tlsCtx $ DBLC.pack $ encodeString+ "<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:param" +++ "s:xml:ns:xmpp-bind\"></bind></iq>"+ return ()+ _ -> do+ loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Setting resource: " +++ (fromJust resource)+ sendData tlsCtx $ DBLC.pack $ encodeString+ "<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:param" +++ "s:xml:ns:xmpp-bind\"><resource>" ++ fromJust resource +++ "</resource></bind></iq>"+ return ()+ r <- getID+ sendData tlsCtx $ DBLC.pack $ encodeString $+ "<iq type=\"set\" id=\"" ++ r +++ "\"><session xmlns=\"urn:ietf:params:xml:ns:xmpp-session\"/>" +++ "</iq>"+ writeChan c_ $ XIEAuthenticationSucceeded+ return (s { stateAuthenticationState = Authenticated })+ + -- We have received a SASL challenge on a secure stream+ processEvent (IEX (XEChallenge (Chal challenge)))+ | connectionState == ConnectedTLSSecured tlsCtx = do+ let challenge' = CBBS.decode challenge+ case authenticationState of+ AuthRequested -> do+ -- This is the first challenge - we need to calculate the reply+ loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Received initial challenge: " +++ challenge ++ " (or " ++ challenge' ++ ")"+ random <- getID -- TODO: Length and content.+ case replyToChallenge1 challenge' serverHost (fromJust userName)+ (fromJust password) random of+ Left reply -> do+ let reply' = (filter (/= '\n') (CBBS.encode reply))+ loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Sending challenge response: " +++ reply'+ sendData tlsCtx $ DBLC.pack $ encodeString $+ "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>" +++ reply' ++ "</response>"+ return (s { stateAuthenticationState = Challenge1Processed } )+ Right error -> do+ putStrLn $ show error+ return s+ Challenge1Processed -> do+ -- This is not the first challenge; [...]+ -- TODO: Can we assume "rspauth"?+ loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Received non-initial challenge: " +++ challenge ++ " (or " ++ challenge' ++ ")"+ liftIO $ sendData tlsCtx $ DBLC.pack $ encodeString $+ "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/>"+ return s+ + -- We have received a SASL "success" message over a secured connection+ -- TODO: Parse the success message?+ -- TODO: <?xml version='1.0'?>?+ processEvent (IEX (XESuccess (Succ _)))+ | connectionState == ConnectedTLSSecured tlsCtx = do+ loggerLog l (Just ("Session", "processEvent")) Debug $+ "processEvent: Received authentication success: [...]; restartin" +++ "g stream" -- TODO+ sendData tlsCtx $ DBLC.pack $+ encodeString "<?xml version='1.0'?><stream:stream to='" +++ serverHost +++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" +++ "streams' version='1.0'>"+ return s { stateAuthenticationState = Authenticated }+ + -- Ignore id="bind_1" and session IQ result, otherwise create client event+ processEvent (IEX (XEIQ iqEvent))+ | authenticationState == Authenticated = do+ case shouldIgnoreIQ iqEvent of+ True ->+ return s+ False -> do+ loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Got IQ for client: " +++ (show iqEvent)+ writeChan c_ $ XIEIQ iqEvent+ return s+ + processEvent (IEX (XEPresence presenceEvent))+ | authenticationState == Authenticated = do+ loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Got presence for client: " +++ (show presenceEvent)+ writeChan c_ $ XIEPresence presenceEvent+ return s+ + processEvent (IEX (XEMessage messageEvent)) = do+ loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Got message for client: " +++ (show messageEvent)+ writeChan c_ $ XIEMessage messageEvent+ return s+ + -- We received an XML element that we didn't parse+ processEvent (IEX xmlEvent) = do+ loggerLog l (Just ("Session", "processEvent")) Warning $ "processEvent: XML event slipped through: " +++ (show xmlEvent)+ return s++ shouldIgnoreIQ :: IQ -> Bool+ shouldIgnoreIQ i = case iqPayload i of+ Nothing -> False+ Just e -> case nameNamespace $ elementName e of+ Just x | x == DT.pack "urn:ietf:params:xml:ns:xmpp-bind" -> True+ Just x | x == DT.pack "urn:ietf:params:xml:ns:xmpp-session" -> True+ Just _ -> False+ Nothing -> False+ +parseIQ :: Element -> IQ+parseIQ e | typeAttr == "get" = let (Just payloadMust) = payload+ in iqGet idAttr fromAttr toAttr Nothing+ payloadMust+ | typeAttr == "set" = let (Just payloadMust) = payload+ in iqSet idAttr fromAttr toAttr Nothing+ payloadMust+ | typeAttr == "result" = iqResult idAttr fromAttr toAttr Nothing+ payload++ where+ -- TODO: Many duplicate functions from parsePresence.+ + payload :: Maybe Element+ payload = case null (elementChildren e) of+ True -> Nothing+ False -> Just $ head $ elementChildren e+ + typeAttr :: String+ typeAttr = case attributeText typeName e of+ -- Nothing -> Nothing+ Just a -> DT.unpack a+ + fromAttr :: Maybe JID+ fromAttr = case attributeText fromName e of+ Nothing -> Nothing+ Just a -> stringToJID $ DT.unpack a+ + toAttr :: Maybe JID+ toAttr = case attributeText toName e of+ Nothing -> Nothing+ Just a -> stringToJID $ DT.unpack a+ + idAttr :: Maybe StanzaID+ idAttr = case attributeText idName e of+ Nothing -> Nothing+ Just a -> Just (SID (DT.unpack a))+ + typeName :: Name+ typeName = fromString "type"+ + fromName :: Name+ fromName = fromString "from"+ + toName :: Name+ toName = fromString "to"+ + idName :: Name+ idName = fromString "id"++-- TODO: Parse xml:lang++parsePresence :: Element -> Presence+parsePresence e = presence idAttr fromAttr toAttr Nothing typeAttr (elementChildren e)+ where+ -- TODO: Many duplicate functions from parseIQ.+ + typeAttr :: PresenceType+ typeAttr = case attributeText typeName e of+ Just t -> stringToPresenceType $ DT.unpack t+ Nothing -> Available+ + fromAttr :: Maybe JID+ fromAttr = case attributeText fromName e of+ Nothing -> Nothing+ Just a -> stringToJID $ DT.unpack a+ + toAttr :: Maybe JID+ toAttr = case attributeText toName e of+ Nothing -> Nothing+ Just a -> stringToJID $ DT.unpack a+ + idAttr :: Maybe StanzaID+ idAttr = case attributeText idName e of+ Nothing -> Nothing+ Just a -> Just (SID (DT.unpack a))+ + fromName :: Name+ fromName = fromString "from"+ + typeName :: Name+ typeName = fromString "type"+ + toName :: Name+ toName = fromString "to"+ + idName :: Name+ idName = fromString "id"++parseMessage :: Element -> Message+parseMessage e = message idAttr fromAttr toAttr Nothing typeAttr (elementChildren e)+ where+ -- TODO: Many duplicate functions from parseIQ.+ + typeAttr :: MessageType+ typeAttr = case attributeText typeName e of+ Just t -> stringToMessageType $ DT.unpack t+ Nothing -> Normal+ + fromAttr :: Maybe JID+ fromAttr = case attributeText fromName e of+ Nothing -> Nothing+ Just a -> stringToJID $ DT.unpack a+ + toAttr :: Maybe JID+ toAttr = case attributeText toName e of+ Nothing -> Nothing+ Just a -> stringToJID $ DT.unpack a+ + idAttr :: Maybe StanzaID+ idAttr = case attributeText idName e of+ Nothing -> Nothing+ Just a -> Just (SID (DT.unpack a))+ + fromName :: Name+ fromName = fromString "from"+ + typeName :: Name+ typeName = fromString "type"+ + toName :: Name+ toName = fromString "to"+ + idName :: Name+ idName = fromString "id"++-- stringToPresenceType "available" = Available+-- stringToPresenceType "away" = Away+-- stringToPresenceType "chat" = Chat+-- stringToPresenceType "dnd" = DoNotDisturb+-- stringToPresenceType "xa" = ExtendedAway++stringToPresenceType "probe" = Probe+stringToPresenceType "error" = PresenceError++stringToPresenceType "unavailable" = Unavailable+stringToPresenceType "subscribe" = Subscribe+stringToPresenceType "subscribed" = Subscribed+stringToPresenceType "unsubscribe" = Unsubscribe+stringToPresenceType "unsubscribed" = Unsubscribed++-- presenceTypeToString Available = "available"++-- presenceTypeToString Away = "away"+-- presenceTypeToString Chat = "chat"+-- presenceTypeToString DoNotDisturb = "dnd"+-- presenceTypeToString ExtendedAway = "xa"++presenceTypeToString Unavailable = "unavailable"++presenceTypeToString Probe = "probe"+presenceTypeToString PresenceError = "error"++presenceTypeToString Subscribe = "subscribe"+presenceTypeToString Subscribed = "subscribed"+presenceTypeToString Unsubscribe = "unsubscribe"+presenceTypeToString Unsubscribed = "unsubscribed"++stringToMessageType "chat" = Chat+stringToMessageType "error" = MessageError+stringToMessageType "groupchat" = Groupchat+stringToMessageType "headline" = Headline+stringToMessageType "normal" = Normal+stringToMessageType s = OtherMessageType s++messageTypeToString Chat = "chat"+messageTypeToString MessageError = "error"+messageTypeToString Groupchat = "groupchat"+messageTypeToString Headline = "headline"+messageTypeToString Normal = "normal"+messageTypeToString (OtherMessageType s) = s++xmlEnumerator :: Chan InternalEvent -> Handle -> String -> Logger -> IO ()+xmlEnumerator c h s l = do+ loggerLog l (Just ("Session", "processEvent")) Debug $ "xmlEnumerator: Starting to read insecure XML"+ run_ $ enumHandle 1 h $$ joinI $ parseBytes decodeEntities+ $$ xmlReader c [] 0+ loggerLog l (Just ("Session", "processEvent")) Debug $ "xmlEnumerator: Unsecure stream ended - performing TLS handshake"+ t <- handshake' h s+ case t of+ Just tlsctx -> do loggerLog l (Just ("Session", "processEvent")) Debug $ "xmlEnumerator: Handshake successful - st" +++ "arting to read secure XML"+ writeChan c (IES (TLSSucceeded tlsctx))+ run_ $ enumTLS tlsctx $$ joinI $ parseBytes decodeEntities+ $$ xmlReader c [] 0+ loggerLog l (Just ("Session", "processEvent")) Debug $+ "xmlEnumerator: Secure stream ended, exiting"+ return ()+ Nothing -> loggerLog l (Just ("Session", "processEvent")) Debug $ "xmlEnumerator: TLS handshake failed" -- TODO: Event+ return ()++enumTLS :: TLSCtx -> E.Enumerator DB.ByteString IO b+enumTLS c s = loop c s where+ loop :: TLSCtx -> E.Step DB.ByteString IO b -> E.Iteratee DB.ByteString IO b+ loop c (E.Continue k) =+ do d <- recvData c+ case DBL.null d of+ True -> loop c (E.Continue k)+ False -> k (E.Chunks $ DBL.toChunks d) E.>>== loop c+ loop _ step = E.returnI step++hPutStr' :: Handle -> String -> IO ()+hPutStr' h s = do+ hPutStr h $ encodeString "<?xml version='1.0'?><stream:stream to='" +++ s ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" +++ "streams' version='1.0'>"+ hFlush h++getTLSParams :: TLSParams+getTLSParams = TLSParams { pConnectVersion = TLS10+ , pAllowedVersions = [TLS10,TLS11]+ , pCiphers = [cipher_AES256_SHA1] -- Check the rest+ , pCompressions = [nullCompression]+ , pWantClientCert = False+ , pCertificates = []+ , onCertificatesRecv = \_ -> return True } -- Verify cert chain++handshake' :: Handle -> String -> IO (Maybe TLSCtx)+handshake' h s = do+ let t = getTLSParams+ r <- makeSRandomGen+ case r of+ Right sr -> do+ putStrLn $ show sr+ c <- client t sr h+ handshake c+ sendData c $ DBLC.pack $ encodeString "<?xml version='1.0'?><stream:stream to='" +++ s ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" +++ "streams' version='1.0'>"+ putStrLn ">>>>TLS data sended<<<<"+ return (Just c)+ Left ge -> do+ putStrLn $ show ge+ return Nothing+++-- TODO: Add logger++xmlReader :: Chan InternalEvent -> [Event] -> Int ->+ Iteratee Event IO (Maybe Event)++xmlReader ch [EventBeginDocument] 0 = xmlReader ch [] 0++-- TODO: Safe to start change level here? We are doing this since the stream can+-- restart.+-- TODO: l < 2?+xmlReader ch [EventBeginElement name attribs] l+ | l < 3 && nameLocalName name == DT.pack "stream" &&+ namePrefix name == Just (DT.pack "stream") = do+ liftIO $ writeChan ch $ IEX $ XEBeginStream $ defaultStream "TODO"+ xmlReader ch [] 1++xmlReader ch [EventEndElement name] 1+ | namePrefix name == Just (DT.pack "stream") &&+ nameLocalName name == DT.pack "stream" = do+ liftIO $ writeChan ch $ IEX XEEndStream+ return Nothing++-- Check if counter is one to forward it to related function.+-- Should replace "reverse ((EventEndElement n):es)" with es+-- ...+xmlReader ch ((EventEndElement n):es) 1+ | nameLocalName n == DT.pack "proceed" = E.yield Nothing (E.Chunks [])+ | otherwise = do+ -- liftIO $ putStrLn "Got an IEX Event..."+ liftIO $ writeChan ch $ IEX (processEventList (DL.reverse ((EventEndElement n):es)))+ xmlReader ch [] 1++-- Normal condition, buffer the event to events list.+xmlReader ch es co = do+ head <- EL.head+ let co' = counter co head+ liftIO $ putStrLn $ show co' ++ "\t" ++ show head -- for test+ case head of+ Just e -> xmlReader ch (e:es) co'+ Nothing -> xmlReader ch es co'+++-- TODO: Generate real event.+processEventList :: [Event] -> XMLEvent+processEventList e+ | namePrefix name == Just (DT.pack "stream") &&+ nameLocalName name == DT.pack "features" = XEFeatures featuresDefault+ | nameLocalName name == DT.pack "challenge" =+ let EventContent (ContentText c) = head es in XEChallenge $ Chal $ DT.unpack c+ | nameLocalName name == DT.pack "success" =+ let EventContent (ContentText c) = head es in XESuccess $ Succ $ DT.unpack c+ | nameLocalName name == DT.pack "iq" = XEIQ $ parseIQ $ eventsToElement e+ | nameLocalName name == DT.pack "presence" = XEPresence $ parsePresence $ eventsToElement e+ | nameLocalName name == DT.pack "message" = XEMessage $ parseMessage $ eventsToElement e+ | otherwise = XEOther $ elementToString $ Just (eventsToElement e)+ where+ (EventBeginElement name attribs) = head e+ es = tail e++eventsToElement :: [Event] -> Element+eventsToElement e = do+ documentRoot $ fromJust (run_ $ enum e $$ fromEvents)+ where+ enum :: [Event] -> E.Enumerator Event Maybe Document+ enum e_ (E.Continue k) = k $ E.Chunks e_+ enum e_ step = E.returnI step++counter :: Int -> Maybe Event -> Int+counter c (Just (EventBeginElement _ _)) = (c + 1)+counter c (Just (EventEndElement _) ) = (c - 1)+counter c _ = c++presenceToXML :: Presence -> String+presenceToXML p = "<presence" ++ from ++ id' ++ to ++ type' ++ ">" +++ (elementsToString $ presencePayload p) ++ "</presence>"+ where+ s = presenceStanza p+ + from :: String+ from = case stanzaFrom $ presenceStanza p of+ -- TODO: Lower-case+ Just s -> " from='" ++ (jidToString s) ++ "'"+ Nothing -> ""+ + id' :: String+ id' = case stanzaID s of+ Just (SID s) -> " id='" ++ s ++ "'"+ Nothing -> ""+ + to :: String+ to = case stanzaTo $ presenceStanza p of+ -- TODO: Lower-case+ Just s -> " to='" ++ (jidToString s) ++ "'"+ Nothing -> ""+ + type' :: String+ type' = case presenceType p of+ Available -> ""+ t -> " type='" ++ (presenceTypeToString t) ++ "'"++iqToXML :: IQ -> String+iqToXML IQGet { iqGetStanza = s, iqGetPayload = p } =+ let type' = " type='get'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString (Just p)) ++ "</iq>"+ where+ from :: String+ from = case stanzaFrom s of+ -- TODO: Lower-case+ Just s -> " from='" ++ (jidToString s) ++ "'"+ Nothing -> ""+ + id' :: String+ id' = case stanzaID s of+ Just (SID s) -> " id='" ++ s ++ "'"+ Nothing -> ""+ + to :: String+ to = case stanzaTo s of+ -- TODO: Lower-case+ Just s -> " to='" ++ (jidToString s) ++ "'"+ Nothing -> ""++iqToXML IQSet { iqSetStanza = s, iqSetPayload = p } =+ let type' = " type='set'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString (Just p)) ++ "</iq>"+ where+ from :: String+ from = case stanzaFrom s of+ -- TODO: Lower-case+ Just s -> " from='" ++ (jidToString s) ++ "'"+ Nothing -> ""+ + id' :: String+ id' = case stanzaID s of+ Just (SID s) -> " id='" ++ s ++ "'"+ Nothing -> ""+ + to :: String+ to = case stanzaTo s of+ -- TODO: Lower-case+ Just s -> " to='" ++ (jidToString s) ++ "'"+ Nothing -> ""++iqToXML IQResult { iqResultStanza = s, iqResultPayload = p } =+ let type' = " type='result'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString p) ++ "</iq>"+ where+ from :: String+ from = case stanzaFrom s of+ -- TODO: Lower-case+ Just s -> " from='" ++ (jidToString s) ++ "'"+ Nothing -> ""+ + id' :: String+ id' = case stanzaID s of+ Just (SID s) -> " id='" ++ s ++ "'"+ Nothing -> ""+ + to :: String+ to = case stanzaTo s of+ -- TODO: Lower-case+ Just s -> " to='" ++ (jidToString s) ++ "'"+ Nothing -> ""++messageToXML :: Message -> String+messageToXML m = "<message" ++ from ++ id' ++ to ++ type' ++ ">" +++ (elementsToString $ messagePayload m) ++ "</message>"+ where+ s = messageStanza m+ + from :: String+ from = case stanzaFrom $ messageStanza m of+ -- TODO: Lower-case+ Just s -> " from='" ++ (jidToString s) ++ "'"+ Nothing -> ""+ + id' :: String+ id' = case stanzaID s of+ Just (SID s) -> " id='" ++ s ++ "'"+ Nothing -> ""+ + to :: String+ to = case stanzaTo $ messageStanza m of+ -- TODO: Lower-case+ Just s -> " to='" ++ (jidToString s) ++ "'"+ Nothing -> ""+ + type' :: String+ type' = case messageType m of+ Normal -> ""+ t -> " type='" ++ (messageTypeToString t) ++ "'"
+ Network/XMPP/Stanza.hs view
@@ -0,0 +1,237 @@+-- | Module: $Header$+-- Description: XMPP stanza types and utility functions+-- Copyright: Copyright © 2010-2011 Jon Kristensen+-- License: BSD-3+-- +-- Maintainer: info@pontarius.org+-- Stability: unstable+-- Portability: portable+-- +-- This module will be documented soon.++-- Received stanzas can be assumed to have their ID and to fields set.++-- TODO: Handle error stanzas++module Network.XMPP.Stanza ( StanzaID (SID)+ , From+ , To+ , XMLLang+ , Stanza (..)+ , MessageType (..)+ , Message (..)+ , message+ , PresenceType (..)+ , Presence (..)+ , presence+ , IQ (..)+ , iqGet+ , iqSet+ , iqResult+ , iqStanza+ , iqPayloadNamespace+ , iqPayload ) where++import Network.XMPP.JID++import Data.XML.Types+import qualified Data.Text as DT+++data StanzaID = SID String deriving (Eq, Show)+type From = JID+type To = JID+type XMLLang = String -- Validate, protect+++data Stanza = Stanza { stanzaID :: Maybe StanzaID+ , stanzaFrom :: Maybe From+ , stanzaTo :: Maybe To+ , stanzaLang :: Maybe XMLLang } deriving (Eq, Show)+++stanza :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang -> Stanza++stanza i f t l = Stanza { stanzaID = i+ , stanzaFrom = f+ , stanzaTo = t+ , stanzaLang = l }+++data MessageType = Chat |+ MessageError |+ Groupchat |+ Headline |+ Normal | -- Default+ OtherMessageType String deriving (Eq, Show)+++data Message = Message { messageStanza :: Stanza+ , messageType :: MessageType+ , messagePayload :: [Element] } deriving (Eq, Show)+++message :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang ->+ MessageType -> [Element] -> Message++message i f t l t_ p = Message { messageStanza = stanza i f t l+ , messageType = t_+ , messagePayload = p }+++data PresenceType = Subscribe | -- ^ Sender wants to subscribe to presence+ Subscribed | -- ^ Sender has approved the subscription+ Unsubscribe | -- ^ Sender is unsubscribing from presence+ Unsubscribed | -- ^ Sender has denied or cancelled a+ -- subscription+ Probe | -- ^ Sender requests current presence;+ -- should only be used by servers+ PresenceError | -- ^ Processing or delivery of previously+ -- sent presence stanza failed+ Available | -- Not part of type='' [...]+ -- Away |+ -- Chat |+ -- DoNotDisturb |+ -- ExtendedAway |+ Unavailable+ deriving (Eq, Show)+++-- | Presence stanzas are used to express an entity's network availability.++data Presence = Presence { presenceStanza :: Stanza+ , presenceType :: PresenceType+ , presencePayload :: [Element] } deriving (Eq, Show)+++presence :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang ->+ PresenceType -> [Element] -> Presence++presence i f t l t_ p = Presence { presenceStanza = Stanza { stanzaID = i+ , stanzaFrom = f+ , stanzaTo = t+ , stanzaLang = l }+ , presenceType = t_+ , presencePayload = p }+++data IQ = IQGet { iqGetStanza :: Stanza, iqGetPayload :: Element } |+ IQSet { iqSetStanza :: Stanza, iqSetPayload :: Element } |+ IQResult { iqResultStanza :: Stanza+ , iqResultPayload :: Maybe Element } deriving (Eq, Show)+++iqGet :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang -> Element ->+ IQ++iqGet i f t l p = IQGet { iqGetStanza = Stanza { stanzaID = i+ , stanzaFrom = f+ , stanzaTo = t+ , stanzaLang = l }+ , iqGetPayload = p }+++iqSet :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang -> Element ->+ IQ++iqSet i f t l p = IQSet { iqSetStanza = Stanza { stanzaID = i+ , stanzaFrom = f+ , stanzaTo = t+ , stanzaLang = l }+ , iqSetPayload = p }+++iqResult :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang ->+ Maybe Element -> IQ++iqResult i f t l p = IQResult { iqResultStanza = Stanza { stanzaID = i+ , stanzaFrom = f+ , stanzaTo = t+ , stanzaLang = l }+ , iqResultPayload = p }+++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++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)+++-- =============================================================================+-- CODE NOT YET USED+-- =============================================================================+++-- | 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)+++-- IM/RFC:+-- data PresenceStatus = PS String deriving (Eq, Show)++-- -- TODO: Validate input.++-- presenceStatus :: String -> Maybe PresenceStatus+-- presenceStatus s = Just (PS s)
+ Network/XMPP/Utilities.hs view
@@ -0,0 +1,109 @@+-- | Module: $Header$+-- Description: Utility functions for Pontarius XMPP; currently only random ID+-- generation functions+-- Copyright: Copyright © 2010-2011 Jon Kristensen+-- License: BSD-3+-- +-- Maintainer: info@pontarius.org+-- Stability: unstable+-- Portability: portable+-- +-- This module will be documented soon.++-- TODO: Document this module+-- TODO: Make is possible to customize characters+-- TODO: Make it possible to customize length++module Network.XMPP.Utilities ( elementToString+ , elementsToString+ , getID+ , getID_) where++import Data.Word+import Data.XML.Types+import System.Crypto.Random+import System.Random+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)++++-- =============================================================================+-- XML Utilities+-- =============================================================================+++elementsToString :: [Element] -> String+elementsToString [] = ""+elementsToString (e:es) = (elementToString $ Just e) ++ elementsToString es++elementToString :: Maybe Element -> String+elementToString Nothing = ""+elementToString (Just e) = "<" ++ nameToString (elementName e) ++ xmlns +++ attributes (DM.toList (elementAttributes e)) +++ ">" ++ (nodesToString $ elementNodes e) ++ "</" +++ nameToString (elementName e) ++ ">"+ where+ xmlns :: String+ xmlns = case nameNamespace $ elementName e of+ Nothing -> ""+ Just t -> " xmlns='" ++ (DT.unpack t) ++ "'"+ + nameToString :: Name -> String+ nameToString Name { nameLocalName = n, namePrefix = Nothing } = DT.unpack n+ nameToString Name { nameLocalName = n, namePrefix = Just p } =+ (DT.unpack p) ++ ":" ++ (DT.unpack n)++ contentToString :: Content -> String+ contentToString (ContentText t) = DT.unpack t+ contentToString (ContentEntity t) = DT.unpack t+ + attributes :: [(Name, [Content])] -> String+ attributes [] = ""+ attributes ((n, c):t) = (" " ++ (nameToString n) ++ "='" +++ concat (map contentToString c) ++ "'") +++ attributes t+ + nodesToString :: [Node] -> String+ nodesToString [] = ""+ nodesToString ((NodeElement e):ns) = (elementToString $ Just e) +++ (nodesToString ns)+ nodesToString ((NodeContent c):ns) = (contentToString c) +++ (nodesToString ns)
README view
@@ -1,25 +1,21 @@ Pontarius XMPP aims to be a secure and easy-to-use XMPP library for Haskell. We-have just released a second alpha version with the following features:+have just released a third alpha version with the following features: * Client-to-server Transport Layer Security and DIGEST-MD5 SASL Authentication- * Concurrent and Event-based API for XMPP Client Developers- * Support for Info/Query and Presence Stanzas+ * Concurrent, Flexible and Event-based API for XMPP Client Developers+ * Support for Info/Query, Presence and Message Stanzas * Interoperable XML Parsing (Using enumerator, xml-enumerator and xml-types) Please note that we are not recommending anyone to use Pontarius XMPP at this time as it’s still in an experimental stage and will have its API and data types-modified frequently. We have scheduled the first beta release for the 4th of-May. That being said, if you are interested to use Pontarius XMPP anyway, feel-free to contact the Pontarius project and we will try to help you get started.+modified. However, if you are interested to use Pontarius XMPP anyway, feel free+to contact the Pontarius project and we will try to help you get started. You+can also see the Example directory for a usage example. We are currently working on general improvements, securing the client-to-client-communication and having the library support all of RFC 3920: XMPP Core (by for-example supporting message stanzas).--We will release the next version, 0.1 Alpha 3, on the 13th of April.+communication and having the library support all of RFC 3920: XMPP Core. -Check pontarius-xmpp.cabal for dependency information if you want to build-Pontarius XMPP by hand.+We will release the next version, 0.1 Alpha 4, on the 4th of May. Look at the Pontarius web site <http://www.pontarius.org/>, the Pontarius XMPP web page <http://www.pontarius.org/projects/pontarius-xmpp/> and the Pontarius
− Test.hs
@@ -1,35 +0,0 @@--- module Test where--import Control.Concurrent.Chan (Chan, readChan, writeChan)-import Network.XMPP.PontariusXMPP-import Data.XML.Types-import qualified Data.Text as DT-import Data.Maybe--host = "test.pontarius.org"-user = "sprint1"-server = "test.pontarius.org"-port = 5222-resource = "pontarius"-password = ""--main :: IO ()-main =- do (co, ci) <- connect host port -- TODO: In, Out- (jid (Just user) server (Just resource)) password- writeChan co $ presenceEvent DoNotDisturb (presenceStatus "Pontarius XMPP 0.1 Alpha 2 Test")- loop ci--loop :: Chan ClientInEvent -> IO ()-loop c =- do e <- readChan c- processEvent e- loop c-- where- processEvent :: ClientInEvent -> IO ()- processEvent (CIEIQGet (i, f, t, e))- | (nameNamespace $ elementName e) /= Nothing &&- (DT.unpack $ fromJust (nameNamespace $ elementName e)) ==- "http://jabber.org/protocol/disco#info" = putStrLn "Disco info!"- | otherwise = putStrLn $ ">>>>>>>>>> " ++ (show e)
+ XTLS.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-} +++module XTLS (start) where++import Network.XMPP+import Control.Concurrent (forkIO)+import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)++import Data.XML.Types+import Network.XMPP.Stanza+import Control.Monad ((>=>))+import Data.Maybe++data State = State {}++start :: IO ()+start = putStrLn "Test"++stateLoop :: State -> Chan XMPPInEvent -> Chan XMPPOutEvent -> IO ()+stateLoop s c c_ = do+ e <- readChan c+ s' <- processEvent e s c_+ stateLoop s' c c_++processEvent :: XMPPInEvent -> State -> Chan XMPPOutEvent -> IO State+-- processEvent (PATTERN_MATCHING) s c = do+-- return s+processEvent (XIEIQ iq) s c = do+ -- putStrLn+ case xtlsOrJingle iq of+ 'j' -> return s+ 'x' -> return s+ 'n' -> return s++xtlsOrJingle :: IQ -> Char+xtlsOrJingle iq =+ case iqPayloadNamespace iq of+ Just "urn:xmpp:jingle:1" ->+ case isXTLS $ head $ getContent (fromJust $ iqPayload iq) of+ [] -> 'j'+ other -> 'x'+ other -> 'n'+ where+ isXTLS :: Element -> [Element]+ isXTLS = elementChildren >=> isNamed xtlsName++ getContent :: Element -> [Element]+ getContent = elementChildren >=> isNamed "content"+++xtlsName :: Name+xtlsName = ( "{urn:xmpp:jingle:security:xtls:0}security" :: Name )++-- Jingle Event base on the XEP-166+data JingleEvent = ContentAccept | ContentAdd | ContentModify | ContentReject |+ ContentRemove | DiscriptionInfo | TransportAccept |+ TransportInfo | TransportReject | TransportReplace++data JingleSession = Initiated { sid :: String , candidate :: [Candidate] } |+ Accepted { sid :: String , candidate :: [Candidate] } |+ Media { sid :: String } |+ Terminated { sid :: String }++data Candidate = Candidate { id :: Int ,+ ip :: String ,+ portNum :: Int ,+ priority :: Int }++data Transport = IBB { transid :: String , blockSize :: Int} |+ OBB { transid :: String } -- TODO : define the OBB+++data XTLSSecurity = XTLSSecurity { fingerPrint :: String , methods :: [MethodName]}+data MethodName = SRP | X509
pontarius-xmpp.cabal view
@@ -2,7 +2,7 @@ -- TODO: Highlighting bug: The last line of the description. Name: pontarius-xmpp-Version: 0.0.2.0+Version: 0.0.3.0 Cabal-Version: >= 1.6 Build-Type: Simple License: BSD3@@ -13,8 +13,8 @@ Stability: alpha Homepage: http://www.pontarius.org/projects/pontarius-xmpp/ Bug-Reports: mailto:info@pontarius.org-Package-URL: http://www.pontarius.org/releases/pontarius-xmpp-0.0.2.0.tar.gz-Synopsis: A (prototyped) easy to use XMPP library+Package-URL: http://www.pontarius.org/releases/pontarius-xmpp-0.0.3.0.tar.gz+Synopsis: A (prototyped) secure and easy to use XMPP library Description: A work in progress of an implementation of RFC 3920: XMPP Core. Category: Network@@ -25,12 +25,15 @@ -- Extra-Tmp-Files: Library- Exposed-Modules: Network.XMPP.PontariusXMPP+ Exposed-Modules: Network.XMPP, Network.XMPP.JID, Network.XMPP.SASL,+ Network.XMPP.Session, Network.XMPP.Stanza,+ Network.XMPP.Utilities Exposed: True- Build-Depends: hlogger ==0.0.2.0, base >= 2 && < 5, enumerator,+ 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, containers+ bytestring, binary, random, xml-enumerator, tls ==0.4.1,+ containers -- Other-Modules: -- HS-Source-Dirs: -- Extensions:@@ -51,12 +54,13 @@ -- Pkgconfig-Depends: -- Frameworks: -Executable pontarius-xmpp-test- Main-Is: Test.hs- Build-Depends: hlogger ==0.0.2.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, containers+-- 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 -- Other-Modules: -- HS-Source-Dirs: -- Extensions:@@ -87,5 +91,5 @@ Type: darcs -- Module: Location: https://patch-tag.com/r/jonkri/pontarius-xmpp- Tag: 0.0.2.0+ Tag: 0.0.3.0 -- Subdir: