diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 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. diff --git a/Network/XMPP/PontariusXMPP.hs b/Network/XMPP/PontariusXMPP.hs new file mode 100644 --- /dev/null +++ b/Network/XMPP/PontariusXMPP.hs @@ -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 +-- 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 +-- . 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 "" 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 "" 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 "" + 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 "" + 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 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 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 "" + hFlush handle + return s + + -- We have received 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 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 + "" ++ fromJust resource ++ + "" + r <- getID + sendData (fromJust tlsCtx) $ DBLC.pack $ encodeString $ + "" + 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 $ + "" ++ + reply' ++ "" + 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 $ + "" + return s + + -- We have received a SASL "success" message over a secured connection + -- TODO: Parse the success message? + -- TODO: ? + processEvent (IEX (XESuccess (Succ _))) | securityState == TLSSecured = do + logDebug l $ + "processEvent: Received authentication success: [...]; restarting " ++ + "stream" -- TODO + sendData (fromJust tlsCtx) $ DBLC.pack $ + encodeString "" + 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 = "" + +-- --------------------------------------------------------------------------- +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)) = + "5" ++ (presence_ presenceType) ++ "" +clientOutEventToXML (COESimplePresence (presenceType, Just (PS status))) = + "5" ++ (presence_ presenceType) ++ "" ++ status ++ "" +clientOutEventToXML (COEComplexPresence (t, s, e)) = + "" ++ (e' e) ++ "" + 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)) = "" ++ (elementToString $ Just e) ++ "" + 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)) = "" ++ (elementToString $ Just e) ++ "" + 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)) = "" ++ (elementToString e) ++ "" + 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) ++ "" + 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) diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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 , the Pontarius XMPP +web page and the Pontarius +XMPP Hackage page for more +information. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/Test.hs b/Test.hs new file mode 100644 --- /dev/null +++ b/Test.hs @@ -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) diff --git a/install.sh b/install.sh new file mode 100644 --- /dev/null +++ b/install.sh @@ -0,0 +1,5 @@ +#!/bin/sh +runhaskell Setup.hs configure --user +runhaskell Setup.hs build +runhaskell Setup.hs install + diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal new file mode 100644 --- /dev/null +++ b/pontarius-xmpp.cabal @@ -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: