pontarius-xmpp (empty) → 0.0.2.0
raw patch · 7 files changed
+1595/−0 lines, 7 filesdep +basedep +base64-stringdep +binarysetup-changed
Dependencies added: base, base64-string, binary, bytestring, containers, crypto-api, enumerator, hlogger, network, pureMD5, random, regex-posix, text, tls, transformers, utf8-string, xml-enumerator, xml-types
Files
- LICENSE +28/−0
- Network/XMPP/PontariusXMPP.hs +1406/−0
- README +27/−0
- Setup.hs +3/−0
- Test.hs +35/−0
- install.sh +5/−0
- pontarius-xmpp.cabal +91/−0
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright © 2010-2011, Jon Kristensen++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++ * Neither the name of Pontarius, Pontarius XMPP nor the names of its+ contributors may be used to endorse or promote products derived from this+ software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY DIRECT,+INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY+OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,+EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Network/XMPP/PontariusXMPP.hs view
@@ -0,0 +1,1406 @@+-- | 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)
+ README view
@@ -0,0 +1,27 @@+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:++ * 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+ * 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.++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.++Check pontarius-xmpp.cabal for dependency information if you want to build+Pontarius XMPP by hand.++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+XMPP Hackage page <http://hackage.haskell.org/package/pontarius-xmpp/> for more+information.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ Test.hs view
@@ -0,0 +1,35 @@+-- 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)
+ install.sh view
@@ -0,0 +1,5 @@+#!/bin/sh+runhaskell Setup.hs configure --user+runhaskell Setup.hs build+runhaskell Setup.hs install+
+ pontarius-xmpp.cabal view
@@ -0,0 +1,91 @@+-- TODO: Set dependency versions.+-- TODO: Highlighting bug: The last line of the description.++Name: pontarius-xmpp+Version: 0.0.2.0+Cabal-Version: >= 1.6+Build-Type: Simple+License: BSD3+License-File: LICENSE+Copyright: Copyright © 2011, Jon Kristensen+Author: Jon Kristensen, Mahdi Abdinejadi+Maintainer: jon.kristensen@pontarius.org+Stability: alpha+Homepage: http://www.pontarius.org/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+Description: A work in progress of an implementation of RFC 3920: XMPP+ Core.+Category: Network+Tested-With: GHC ==6.12.3+-- Data-Files:+-- Data-Dir:+-- Extra-Source-Files:+-- Extra-Tmp-Files:++Library+ Exposed-Modules: Network.XMPP.PontariusXMPP+ Exposed: True+ 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+ -- Other-Modules:+ -- HS-Source-Dirs:+ -- Extensions:+ -- Build-Tools:+ -- Buildable:+ -- GHC-Options:+ -- GHC-Prof-Options:+ -- Hugs-Options:+ -- NHC98-Options:+ -- Includes:+ -- Install-Includes:+ -- Include-Dirs:+ -- C-Sources:+ -- Extra-Libraries:+ -- Extra-Lib-Dirs:+ -- CC-Options:+ -- LD-Options:+ -- Pkgconfig-Depends:+ -- Frameworks:++Executable pontarius-xmpp-test+ Main-Is: Test.hs+ Build-Depends: hlogger ==0.0.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+ -- Other-Modules:+ -- HS-Source-Dirs:+ -- Extensions:+ -- Build-Tools:+ -- Buildable:+ -- GHC-Options:+ -- GHC-Prof-Options:+ -- Hugs-Options:+ -- NHC98-Options:+ -- Includes:+ -- Install-Includes:+ -- Include-Dirs:+ -- C-Sources:+ -- Extra-Libraries:+ -- Extra-Lib-Dirs:+ -- CC-Options:+ -- LD-Options:+ -- Pkgconfig-Depends:+ -- Frameworks:++Source-Repository head+ Type: darcs+ -- Module:+ Location: https://patch-tag.com/r/jonkri/pontarius-xmpp+ -- Subdir:++Source-Repository this+ Type: darcs+ -- Module:+ Location: https://patch-tag.com/r/jonkri/pontarius-xmpp+ Tag: 0.0.2.0+ -- Subdir: