diff --git a/Examples/EchoClient.hs b/Examples/EchoClient.hs
new file mode 100644
--- /dev/null
+++ b/Examples/EchoClient.hs
@@ -0,0 +1,73 @@
+{-
+
+This file (EchoClient.hs) illustrates how to connect, authenticate and set a
+presence with Pontarius XMPP. The contents of this file may be used freely, as
+if it is in the public domain.
+
+-}
+
+
+import Network.XMPP
+
+import Control.Concurrent.Chan (Chan, readChan, writeChan)
+import Data.Maybe
+import Data.XML.Types
+import qualified Data.Text as DT
+
+
+-- Account and server details.
+
+host = "test.pontarius.org"
+userName = "sprint3-xmpp"
+server = "test.pontarius.org"
+port = 5222
+resource = "echo-client"
+password = ""
+
+
+-- Creates a Pontarius XMPP session and requests to connect.
+
+main :: IO ()
+main =
+ do (inEvents, outEvents) <- createSession
+ writeChan outEvents $ XOEConnect host port
+ loop inEvents outEvents
+
+
+-- All "in" events (incoming events to this program, events from Pontarius XMPP)
+-- are being processed in this loop. A state variable could be added here.
+
+loop :: Chan XMPPInEvent -> Chan XMPPOutEvent -> IO ()
+loop c c_ =
+ do e <- readChan c
+ -- putStrLn $ "XMPPInEvent received: " ++ (show e)
+ processEvent e
+ loop c c_
+ where
+ processEvent :: XMPPInEvent -> IO ()
+
+ -- When connected, authenticate
+ processEvent XIEConnectionSucceeded =
+ writeChan c_ $ XOEAuthenticate userName password resource
+
+ -- When authenticated, set presence
+ processEvent XIEAuthenticationSucceeded =
+ writeChan c_ $ XOEPresence $
+ presence Nothing Nothing Nothing Nothing Available []
+
+ -- Auto-accept subscriptions when asked and ask for subscription
+ processEvent (XIEPresence (Presence { presenceStanza = stanza
+ , presenceType = Subscribe })) = do
+ let jid = stanzaFrom stanza
+ writeChan c_ $ XOEPresence $ presence Nothing Nothing jid Nothing
+ Subscribed []
+ writeChan c_ $ XOEPresence $ presence Nothing Nothing jid Nothing
+ Subscribe []
+ return ()
+
+ -- Echo messages
+ processEvent (XIEMessage m) =
+ writeChan c_ $ XOEMessage $
+ message Nothing Nothing (stanzaFrom $ messageStanza m) Nothing
+ (messageType m) (messagePayload m)
+ processEvent _ = return ()
diff --git a/Network/XMPP.hs b/Network/XMPP.hs
new file mode 100644
--- /dev/null
+++ b/Network/XMPP.hs
@@ -0,0 +1,66 @@
+-- | Module: $Header$
+-- Description: A minimalistic and easy-to-use XMPP library
+-- Copyright: Copyright © 2010-2011 Jon Kristensen
+-- License: BSD-3
+--
+-- Maintainer: info@pontarius.org
+-- Stability: unstable
+-- Portability: portable
+
+-- | Pontarius XMPP aims to be a secure, concurrent/event-based and easy-to-use
+-- XMPP library for Haskell. It is being actively developed.
+--
+-- Note that we are not recommending anyone to use Pontarius XMPP at this time
+-- as it's still in an experimental stage and will have its API and data types
+-- modified frequently. See the project's web site at
+-- for more information.
+--
+-- This module will be documented soon.
+
+module Network.XMPP ( -- Network.XMPP.JID
+ JID (..)
+ , jid
+ , jidIsFull
+ , jidIsBare
+ , stringToJID
+ , jidToString
+
+ -- Network.XMPP.SASL
+ , replyToChallenge1
+
+ -- Network.XMPP.Session
+ , XMPPInEvent (..)
+ , XMPPOutEvent (..)
+ , createSession
+
+ -- Network.XMPP.Stanza
+ , StanzaID (SID)
+ , From
+ , To
+ , XMLLang
+ , Stanza (..)
+ , MessageType (..)
+ , Message (..)
+ , message
+ , PresenceType (..)
+ , Presence (..)
+ , presence
+ , IQ (..)
+ , iqGet
+ , iqSet
+ , iqResult
+ , iqStanza
+ , iqPayloadNamespace
+ , iqPayload
+
+ -- Network.XMPP.Utilities
+ , elementToString
+ , elementsToString
+ , getID
+ , getID_ ) where
+
+import Network.XMPP.JID
+import Network.XMPP.SASL
+import Network.XMPP.Session
+import Network.XMPP.Stanza
+import Network.XMPP.Utilities
diff --git a/Network/XMPP/JID.hs b/Network/XMPP/JID.hs
new file mode 100644
--- /dev/null
+++ b/Network/XMPP/JID.hs
@@ -0,0 +1,133 @@
+-- | Module: $Header$
+-- Description: JabberID (JID) data type and utility functions
+-- Copyright: Copyright © 2010-2011 Jon Kristensen
+-- License: BSD-3
+--
+-- Maintainer: info@pontarius.org
+-- Stability: unstable
+-- Portability: portable
+--
+-- JIDs are written in the format of `node@server/resource'. An example of a
+-- JID is `jonkri@jabber.org'.
+--
+-- The node identifier is the part before the `@' character in Jabber IDs.
+-- Node names are optional. The server identifier is the part after the `@'
+-- character in Jabber IDs (and before the `/' character). The server
+-- identifier is the only required field of a JID. The server identifier MAY
+-- be an IP address but SHOULD be a fully qualified domain name. The resource
+-- identifier is the part after the `/' character in Jabber IDs. Like with
+-- node names, the resource identifier is optional.
+--
+-- A JID without a resource identifier (i.e. a JID in the form of
+-- `node@server') is called `bare JID'. A JID with a resource identifier is
+-- called `full JID'.
+
+-- Node identifiers MUST be formatted in such a way so that the Nodeprep profile
+-- (see RFC 3920: XMPP Core, Appendix A) of RFC 3454: Preparation of
+-- Internationalized Strings (`stringprep') can be applied without failing.
+-- Servers MUST and clients SHOULD apply the Nodeprep profile to node names
+-- prior to comparing them. Node identifiers MUST NOT be more than 1023 bytes in
+-- length.
+--
+-- If it is a domain name it MUST be an `internationalized domain name' as
+-- defined in RFC 3490: Internationalizing Domain Names in Applications (IDNA),
+-- to which RFC 3491: Nameprep: A Stringprep Profile for Internationalized
+-- Domain Names (IDN) can be applied without failing. Servers MUST and clients
+-- SHOULD first apply the Nameprep profile to the domain names prior to
+-- comparing them. Like with node names, server identifiers MUST NOT be more
+-- than 1023 bytes in length.
+--
+-- A resource identifier has to be formatted in such a way so that the
+-- Resourceprep profile of RFC 3454: Preparation of Internationalized Strings
+-- (`stringprep') can be applied without failing. Servers MUST and clients
+-- SHOULD first apply the Resourceprep profile (see RFC 3920: XMPP Core,
+-- Appendix B) to resource names prior to comparing them. The resource
+-- identifier MUST MOT be more than 1023 bytes in length.
+--
+-- Given the length of the `@' and `/' characters as well as the restrictions
+-- imposed on the node, server and resource identifiers, a JID will never be
+-- longer than 3071 bytes.
+
+-- TODO: Make the regular expression only match valid JIDs.
+-- TODO: Use Perl regular expressions to use non-capturing groups with "(?:"?
+-- TODO: Validate the input in the jid and stringToJID functions.
+
+module Network.XMPP.JID ( JID (jidNode, jidServer, jidResource)
+ , jid
+ , jidIsFull
+ , jidIsBare
+ , stringToJID
+ , jidToString ) where
+
+import Text.Regex.Posix ((=~))
+
+
+-- JID is a data type that has to be constructed in this module using either jid
+-- or stringToJID.
+
+data JID = JID { jidNode :: Maybe String
+ , jidServer :: String
+ , jidResource :: Maybe String } deriving (Eq, Show)
+
+
+-- | Simple function to construct a JID. We will add validation to this function
+-- in a later release.
+
+jid :: Maybe String -> String -> Maybe String -> JID
+jid n s r = JID { jidNode = n, jidServer = s, jidResource = r }
+
+
+-- | Converts a (JID) String to a JID record.
+
+stringToJID :: String -> Maybe JID
+
+stringToJID string = matchToJID $ string =~ "^(([^@]+)@)?([^/]+)(/(.+))?$"
+ where
+ matchToJID [[_, _, "", server, _, ""]] =
+ Just JID { jidNode = Nothing, jidServer = server, jidResource = Nothing }
+ matchToJID [[_, _, node, server, _, ""]] =
+ Just JID { jidNode = Just node
+ , jidServer = server
+ , jidResource = Nothing }
+ matchToJID [[_, _, "", server, _, resource]] =
+ Just JID { jidNode = Nothing
+ , jidServer = server
+ , jidResource = Just resource }
+ matchToJID [[_, _, node, server, _, resource]] =
+ Just JID { jidNode = Just node
+ , jidServer = server
+ , jidResource = Just resource }
+ matchToJID _ = Nothing
+
+
+-- | Converts a JID to a String.
+
+jidToString :: JID -> String
+
+jidToString JID { jidNode = n, jidServer = s, jidResource = r }
+ | n == Nothing && r == Nothing = s
+ | r == Nothing = let Just n' = n in n' ++ "@" ++ s
+ | n == Nothing = let Just r' = r in s ++ "/" ++ r'
+ | otherwise = let Just n' = n; Just r' = r
+ in n' ++ "@" ++ s ++ "/" ++ r'
+
+
+-- | JIDs are written in the format of `node@server/resource'. A JID without a
+-- resource identifier (i.e. a JID in the form of `server' or `node@server')
+-- is called a `bare JID'. A JID with a resource identifier is called `full
+-- JID'. This function returns True if the JID is `bare' and False otherwise.
+
+jidIsBare :: JID -> Bool
+jidIsBare j | jidResource j == Nothing = True
+ | otherwise = False
+
+
+-- | JIDs are written in the format of `node@server/resource'. A JID without a
+-- resource identifier (i.e. a JID in the form of `server' or `node@server')
+-- is called a `bare JID'. A JID with a resource identifier is called `full
+-- JID'. This function returns True if the JID is `full' and False otherwise.
+
+-- This function is defined in terms of (not) jidIsBare.
+
+jidIsFull :: JID -> Bool
+jidIsFull jid = not $ jidIsBare jid
diff --git a/Network/XMPP/PontariusXMPP.hs b/Network/XMPP/PontariusXMPP.hs
deleted file mode 100644
--- a/Network/XMPP/PontariusXMPP.hs
+++ /dev/null
@@ -1,1406 +0,0 @@
--- | Module: $Header$
--- Description: A minimalistic and easy-to-use XMPP library
--- Copyright: Copyright © 2010-2011 Jon Kristensen
--- License: BSD-3
---
--- Maintainer: info@pontarius.org
--- Stability: unstable
--- Portability: portable
---
--- Pontarius XMPP aims to be a secure, concurrent/event-based and easy-to-use
--- XMPP library for Haskell. It is being actively developed.
---
--- Note that we are not recommending anyone to use Pontarius XMPP at this time
--- as it's still in an experimental stage and will have its API and data types
--- modified frequently. See the project's web site at
--- 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/Network/XMPP/SASL.hs b/Network/XMPP/SASL.hs
new file mode 100644
--- /dev/null
+++ b/Network/XMPP/SASL.hs
@@ -0,0 +1,194 @@
+-- TODO: Make it possible to include host.
+-- TODO: Host is assumed to be ISO 8859-1; make list of assumptions.
+-- TODO: Can it contain newline characters?
+
+module Network.XMPP.SASL (replyToChallenge1) where
+
+import Data.ByteString.Internal (c2w)
+import Data.Char (isLatin1)
+import Data.Digest.Pure.MD5
+import qualified Data.Binary as DBi (Binary, encode)
+import qualified Data.ByteString.Lazy as DBL (ByteString, append, pack,
+ fromChunks, toChunks, null)
+import qualified Data.ByteString.Lazy.Char8 as DBLC (append, pack, unpack)
+import qualified Data.List as DL
+
+
+data Challenge1Error = C1MultipleCriticalAttributes |
+ C1NotAllParametersPresent |
+ C1SomeParamtersPresentMoreThanOnce |
+ C1WrongRealm |
+ C1UnsupportedAlgorithm |
+ C1UnsupportedCharset |
+ C1UnsupportedQOP
+ deriving Show
+
+
+-- Will produce a list of key-value pairs given a string in the format of
+-- realm="somerealm",nonce="OA6MG9tEQGm2hh",qop="auth",charset=utf-8...
+stringToList :: String -> [(String, String)]
+stringToList "" = []
+stringToList s' = let (next, rest) = break' s' ','
+ in break' next '=' : stringToList rest
+ where
+ -- Like break, but will remove the first char of the continuation, if
+ -- present.
+ break' :: String -> Char -> (String, String)
+ break' s' c = let (first, second) = break ((==) c) s'
+ in (first, removeCharIfPresent second c)
+
+ -- Removes the first character, if present; "=hello" with '=' becomes
+ -- "hello".
+ removeCharIfPresent :: String -> Char -> String
+ removeCharIfPresent [] _ = []
+ removeCharIfPresent (c:t) c' | c == c' = t
+ removeCharIfPresent s' c = s'
+
+-- Counts the number of directives in the pair list.
+countDirectives :: String -> [(String, String)] -> Int
+countDirectives v l = DL.length $ filter (isEntry v) l
+ where
+ isEntry :: String -> (String, String) -> Bool
+ isEntry name (name', _) | name == name' = True
+ | otherwise = False
+
+
+-- Returns the given directive in the list of pairs, or Nothing.
+lookupDirective :: String -> [(String, String)] -> Maybe String
+lookupDirective d [] = Nothing
+lookupDirective d ((d', v):t) | d == d' = Just v
+ | otherwise = lookupDirective d t
+
+
+-- Returns the given directive in the list of pairs, or the default value
+-- otherwise.
+lookupDirectiveWithDefault :: String -> [(String, String)] -> String -> String
+lookupDirectiveWithDefault di l de
+ | lookup == Nothing = de
+ | otherwise = let Just r = lookup in r
+ where
+ lookup = lookupDirective di l
+
+
+-- Takes a challenge string (which is not Base64-encoded), the host name of the
+-- Jabber server, the Jabber user name (JID), the password and a random and
+-- unique "cnonce" value and generates either an error or a response to that
+-- challenge.
+
+-- We have broken replyToChallenge1 for non-TLS authentication. In order to
+-- change it back, just uncomment the lines relevant to the realm and match it
+-- in the C1NotAllParametersSet case.
+
+replyToChallenge1 :: String -> String -> String -> String -> String ->
+ Either String Challenge1Error
+replyToChallenge1 s h u p c =
+ -- Remove all new line characters.
+ let list = stringToList $ filter (/= '\n') s
+ in -- Count that there are no more than one nonce or algorithm directives.
+ case countDirectives "nonce" list <= 1 &&
+ countDirectives "algorithm" list <= 1 of
+ True ->
+ let -- realm = lookupDirective "realm" list
+ nonce = lookupDirective "nonce" list
+ qop = lookupDirectiveWithDefault "qop" list "auth"
+ charset = lookupDirectiveWithDefault "charset" list "utf-8"
+ algorithm = lookupDirective "algorithm" list
+
+ -- Verify that all necessary directives has been set.
+ in case (nonce, qop, charset, algorithm) of
+ (Just nonce', qop', charset', Just algorithm') ->
+
+ -- Strip quotations of the directives that need it.
+ let -- realm'' = stripQuotations realm'
+ nonce'' = stripQuotations nonce'
+ qop'' = stripQuotations qop' -- It seems ejabberd gives us an errorous "auth" instead of auth
+ in
+ -- -- Verify that the realm is the same as the Jabber host.
+ -- case realm'' == h of
+ -- True ->
+
+ -- Verify that QOP is "auth", charset is "utf-8" and that
+ -- the algorithm is "md5-sess".
+ case qop'' == "auth" of
+ True ->
+ case charset' == "utf-8" of
+ True ->
+ case algorithm' == "md5-sess" of
+ True ->
+
+ -- All data is valid; generate the reply.
+ Left (reply nonce'' qop'')
+
+ -- Errors are caught and reported below.
+ False -> Right C1UnsupportedAlgorithm
+ False -> Right C1UnsupportedCharset
+ False -> Right C1UnsupportedQOP
+ -- False -> Right C1WrongRealm
+ _ -> Right C1NotAllParametersPresent
+ where
+ reply n q =
+ let -- We start with what's in RFC 2831 is referred to as "A1", a 16 octet
+ -- MD5 hash.
+
+ -- If the username or password values are in ISO-8859-1, we convert
+ -- them to ISO-8859-1 strings.
+ username = case all isLatin1 u of
+ True -> DBL.pack $ map c2w u
+ False -> DBLC.pack $ u
+ password = case all isLatin1 p of
+ True -> DBL.pack $ map c2w p
+ False -> DBLC.pack p
+
+ nc = "00000001"
+ digestUri = "xmpp/" ++ h
+
+ -- Build the "{ username-value, ":", realm-value, ":", passwd }"
+ -- bytestring, the rest of the bytestring and then join them.
+ a1a = DBi.encode $ md5 $ DBLC.append
+ (DBLC.append username (DBLC.pack (":" ++ h ++ ":")))
+ password
+ a1aDebug = "DBi.encode $ md5 $ " ++ (DBLC.unpack $ DBLC.append
+ (DBLC.append username (DBLC.pack (":" ++ h ++ ":")))
+ password)
+ a1b = DBLC.pack (":" ++ n ++ ":" ++ c)
+ a1 = DBLC.append a1a a1b
+
+ -- Generate the "A2" value.
+ a2 = DBLC.pack ("AUTHENTICATE:" ++ digestUri)
+
+ -- Produce the responseValue.
+ k = DBLC.pack (show $ md5 a1)
+ colon = DBLC.pack ":"
+ s0 = DBLC.pack (n ++ ":" ++ nc ++ ":" ++ c ++ ":" ++
+ q ++ ":")
+ s1 = DBLC.pack $ show $ md5 a2
+
+ s_ = DBLC.append s0 s1
+ -- append k:d and 16 octet hash it
+ kd = md5 (DBLC.append k (DBLC.append colon s_))
+
+ lol0 = DBLC.unpack s_
+ lol1 = show kd
+
+ response = show kd
+ in "username=\"" ++ u ++ "\",realm=\"" ++ h ++ "\",nonce=\"" ++ n ++
+ "\",cnonce=\"" ++ c ++ "\",nc=" ++ nc ++ ",digest-uri=\"" ++
+ digestUri ++ "\",qop=auth,response=" ++ response ++ ",charset=utf-8"
+ -- "\n\n" ++
+ -- "a1aDebug: " ++ a1aDebug ++ "\n" ++
+ -- "a1b: " ++ (DBLC.unpack a1b) ++ "\n" ++
+ -- "a1: " ++ (DBLC.unpack a1) ++ "\n" ++
+ -- "a2: " ++ (DBLC.unpack a2) ++ "\n" ++
+ -- "k: " ++ (DBLC.unpack k) ++ "\n" ++
+ -- "colon: " ++ (DBLC.unpack colon) ++ "\n" ++
+ -- "s0: " ++ (DBLC.unpack s0) ++ "\n" ++
+ -- "s1: " ++ (DBLC.unpack s1) ++ "\n" ++
+ -- "s_: " ++ (DBLC.unpack s_) ++ "\n"
+
+
+-- Stripts the quotations around a string, if any; "\"hello\"" becomes "hello".
+
+stripQuotations :: String -> String
+stripQuotations "" = ""
+stripQuotations s | (head s == '"') && (last s == '"') = tail $ init s
+ | otherwise = s
diff --git a/Network/XMPP/Session.hs b/Network/XMPP/Session.hs
new file mode 100644
--- /dev/null
+++ b/Network/XMPP/Session.hs
@@ -0,0 +1,906 @@
+-- | Module: $Header$
+-- Description: XMPP client session management module
+-- Copyright: Copyright © 2010-2011 Jon Kristensen
+-- License: BSD-3
+--
+-- Maintainer: info@pontarius.org
+-- Stability: unstable
+-- Portability: portable
+--
+-- This module will be documented soon.
+
+-- TODO: Send white-space characters with regular intervals to keep the
+-- connection alive.
+-- TODO: Add namespace support for stream/features?
+-- TODO: Add support for `ver optional' support for features?
+-- TODO: Presence priority?
+-- TODO: Stop the logger
+-- TODO: Catch errors
+
+module Network.XMPP.Session ( XMPPInEvent (..)
+ , XMPPOutEvent (..)
+ , createSession ) where
+
+
+import Network.XMPP.JID
+import Network.XMPP.SASL
+import Network.XMPP.Stanza
+import Network.XMPP.Utilities
+
+import Codec.Binary.UTF8.String
+import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
+import Control.Concurrent (forkIO, threadDelay)
+import Control.Monad.IO.Class (liftIO, MonadIO)
+import Data.Enumerator (($$), Iteratee, continue, joinI,
+ run_, yield)
+import Data.Enumerator.Binary (enumHandle, enumFile)
+import Data.Maybe
+import Data.String
+import Data.XML.Types
+import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput)
+import Network
+import Network.TLS
+import Network.TLS.Cipher
+import System.IO (BufferMode, BufferMode(NoBuffering))
+import System.Log.HLogger
+import System.Log.SimpleHLogger
+import Text.XML.Enumerator.Parse (parseBytes, decodeEntities)
+import Text.XML.Enumerator.Document (fromEvents)
+import qualified Codec.Binary.Base64.String as CBBS
+import qualified Data.ByteString as DB
+import qualified Data.ByteString.Lazy as DBL (ByteString, append, pack, fromChunks, toChunks, null)
+import qualified Data.ByteString.Lazy.Char8 as DBLC (append, pack, unpack)
+import qualified Data.Enumerator as E
+import qualified Data.Enumerator.List as EL
+import qualified Data.List as DL
+import qualified Data.Text as DT
+import qualified Data.Text.Lazy as DTL
+
+
+type Server = String
+type Port = Integer
+
+type UserName = String
+type Password = String
+type Resource = String
+
+
+data XMPPInEvent = XIEConnectionSucceeded |
+ XIEConnectionFailed |
+ XIEAuthenticationSucceeded |
+ XIEAuthenticationFailed |
+ XIEMessage Message |
+ XIEPresence Presence |
+ XIEIQ IQ |
+ -- XIEIQJingle | -- Added for Jingle sessions
+ -- XIEIQXTLS | -- Added for XTLS connection
+ XIEDisconnect deriving (Eq, Show)
+
+data XMPPOutEvent = XOEConnect Server Port |
+ XOEAuthenticate UserName Password Resource |
+ XOEMessage Message |
+ XOEPresence Presence |
+ XOEIQ IQ |
+ -- XOEIQJingle | -- Added for Jingle sessions
+ -- XOEIQXTLS | -- Added for XTLS connection
+ XOEDisconnect deriving (Eq, Show)
+
+
+data SecurityEvent = TLSSucceeded TLSCtx | TLSFailed
+
+
+instance Show SecurityEvent where
+ show (TLSSucceeded _) = "TLSSucceeded Ctx"
+ show TLSFailed = "TLSFailed"
+
+
+data ConnectionState = Disconnected |
+ ConnectedNotTLSSecured |
+ ConnectedTLSSecured TLSCtx
+
+instance Eq ConnectionState where
+ (==) Disconnected Disconnected = True
+ (==) ConnectedNotTLSSecured ConnectedNotTLSSecured = True
+ (==) (ConnectedTLSSecured _) (ConnectedTLSSecured _) = True
+ (==) _ _ = False
+
+data AuthenticationState = AuthNotRequested |
+ AuthRequested |
+ Challenge1Processed |
+ Authenticated deriving (Eq)
+
+data State = State { stateConnectionState :: ConnectionState
+ , stateAuthenticationState :: AuthenticationState
+ , stateHandle :: Maybe Handle
+ , stateServer :: Maybe (Server, Port)
+ , stateUserName :: Maybe String
+ , statePassword :: Maybe String
+ , stateResource :: Maybe String
+ , stateStreamID :: Maybe String }
+
+defaultState = State { stateConnectionState = Disconnected
+ , stateAuthenticationState = AuthNotRequested
+ , stateHandle = Nothing
+ , stateServer = Nothing
+ , stateUserName = Nothing
+ , statePassword = Nothing
+ , stateResource = Nothing
+ , stateStreamID = Nothing }
+
+
+-- An XMLEvent is a high-level XMPP event generated by our XML parsing code.
+
+data XMLEvent = XEBeginStream Stream | XEFeatures Features |
+ XEChallenge Challenge | XESuccess Success |
+ XEEndStream | XEIQ IQ | XEPresence Presence |
+ XEMessage Message | XEOther String deriving (Show)
+
+
+-- Represents the top-level "" 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 InternalEvent = IEX XMLEvent |
+ IEO XMPPOutEvent |
+ IES SecurityEvent deriving (Show)
+
+
+-- | Creates a Pontarius XMPP session by setting up internal processes and state
+-- and creates the two (in and out) event channels that the XMPP client uses
+-- for communicating with Pontarius XMPP.
+
+createSession :: IO (Chan XMPPInEvent, Chan XMPPOutEvent)
+
+createSession = do
+ logger <- simpleLogger "PontariusXMPP"
+ loggerLog logger (Just ("Session", "createSession")) Info "Pontarius XMPP has started"
+
+ -- Create client "in" and "out" channels (naming from the perspective of the
+ -- XMPP client) as well as the internal event channel used by the state loop
+ inChan <- newChan
+ outChan <- newChan
+ internalChan <- newChan
+
+ -- Start to listen to client "out" events (client actions)
+ forkIO $ clientListener outChan internalChan logger
+
+ -- Start the state loop, the main loop of Pontarius XMPP
+ forkIO $ stateLoop defaultState internalChan inChan logger
+
+ return (inChan, outChan)
+
+
+-- Receives events from the XMPP client and forwards them to the state loop by
+-- using the internal event channel.
+
+clientListener :: Chan XMPPOutEvent -> Chan InternalEvent -> Logger -> IO ()
+
+clientListener c c_ l =
+ do event <- readChan c
+ loggerLog l (Just ("Session", "clientListener")) Debug $ "clientListener: Forwarding received client event: " ++ show (event)
+ writeChan c_ (IEO event)
+ clientListener c c_ l
+
+
+-- Processes internal events to possibly perform actions and update the session
+-- state. Note that the InternalEvent type wraps the external client events.
+
+stateLoop :: State -> Chan InternalEvent -> Chan XMPPInEvent -> Logger -> IO ()
+
+stateLoop s c c_ l =
+ do event <- readChan c
+ -- logDebug l $ "stateLoop: Received event: " ++ (show event)
+ -- TODO: Debug with state?
+ s' <- processEvent event
+ stateLoop s' c c_ l
+ where
+ connectionState = stateConnectionState s
+ authenticationState = stateAuthenticationState s
+ handle = stateHandle s
+ server = stateServer s
+ userName = stateUserName s
+ password = statePassword s
+ resource = stateResource s
+ streamID = stateStreamID s
+ Just (serverHost, serverPort) = stateServer s
+ tlsCtx = let ConnectedTLSSecured x = connectionState in x
+
+ -- let xml = clientOutEventToXML clientEvent
+ -- logDebug l $ "processEvent: Sending XML: " ++ xml
+ -- sendData (fromJust tlsCtx) $ DBLC.pack $ encodeString $ xml
+
+ processEvent (IEO clientOutEvent) = do
+ loggerLog l (Just ("Session", "processEvent")) Debug $ "Processing client out event " ++ (show clientOutEvent)
+ case clientOutEvent of
+ XOEConnect serverHost_ serverPort_ -> do
+ handle <- connectTo serverHost_ (PortNumber $ fromInteger serverPort_)
+ hSetBuffering handle NoBuffering
+ hPutStr handle $ encodeString $
+ ""
+ hFlush handle
+
+ -- Start XML enumerator, which will read from the handle to generate the
+ -- relevant internal events
+ forkIO $ xmlEnumerator c handle serverHost_ l
+
+ return s { stateConnectionState = ConnectedNotTLSSecured
+ , stateHandle = Just handle
+ , stateServer = Just (serverHost_, serverPort_) }
+
+ -- TODO: Function to verify certificate?
+ XOEAuthenticate userName_ password_ resource_ -> do
+ sendData tlsCtx $ DBLC.pack $ encodeString
+ ""
+ return s { stateAuthenticationState = AuthRequested
+ , stateUserName = Just userName_
+ , statePassword = Just password_
+ , stateResource = Just resource_ }
+
+ XOEPresence presence -> do
+ presence' <- case stanzaID $ presenceStanza presence of
+ Nothing -> do
+ id <- getID
+ return $ presence { presenceStanza = (presenceStanza presence) { stanzaID = Just (SID id) } }
+ _ -> return presence
+
+ let xml = presenceToXML presence'
+ loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Will send presence XML: " ++ xml
+ sendData tlsCtx $ DBLC.pack $ encodeString $ xml
+ return s
+
+ XOEMessage message -> do
+ message' <- case stanzaID $ messageStanza message of
+ Nothing -> do
+ id <- getID
+ return $ message { messageStanza = (messageStanza message) { stanzaID = Just (SID id) } }
+ _ -> return message
+
+ let xml = messageToXML message'
+ loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Will send message XML: " ++ xml
+ sendData tlsCtx $ DBLC.pack $ encodeString $ xml
+ return s
+
+ XOEIQ iq -> do
+ iq' <- case stanzaID $ iqStanza iq of
+ Nothing -> do
+ id <- getID
+ return $ case iq of
+ IQGet {} -> do
+ iq { iqGetStanza = (iqStanza iq) { stanzaID = Just (SID id) } }
+ IQSet {} -> do
+ iq { iqSetStanza = (iqStanza iq) { stanzaID = Just (SID id) } }
+ IQResult {} -> do
+ iq { iqResultStanza = (iqStanza iq) { stanzaID = Just (SID id) } }
+ _ -> return iq
+
+ let xml = iqToXML iq'
+ loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Will send IQ XML: " ++ xml
+ sendData tlsCtx $ DBLC.pack $ encodeString $ xml
+ return s
+
+ XOEDisconnect -> do
+ -- TODO: Close stream
+ return s
+
+ -- TODO: processEvent (IES TLSFailed) =
+
+ processEvent (IES (TLSSucceeded receivedTLSCtx)) =
+ return (s { stateConnectionState = ConnectedTLSSecured receivedTLSCtx })
+
+ -- A element has begun
+ -- TODO: Parse the XEStreamBegin object
+ processEvent (IEX (XEBeginStream _)) = do
+ loggerLog l (Just ("Session", "processEvent")) Debug "processEvent: A new stream has been opened"
+ return s
+
+ -- We have received on an insecure stream
+ -- TODO: Parse the XEFeatures object
+ processEvent (IEX (XEFeatures _))
+ | connectionState == ConnectedNotTLSSecured = do
+ loggerLog l (Just ("Session", "processEvent")) Debug $
+ "processEvent: Received features ([...]) on insecure stream; req" ++
+ "uesting \"starttls\""
+ hPutStr (fromJust handle) $
+ ""
+ hFlush (fromJust handle)
+ return s
+
+ -- We have received on a secure and non-authenticated stream
+ processEvent (IEX (XEFeatures _))
+ | connectionState == ConnectedTLSSecured tlsCtx &&
+ authenticationState /= Authenticated = do
+ loggerLog l (Just ("Session", "processEvent")) Debug $
+ "processEvent: Received features ([...]) on an unauthenticated" ++
+ " secure stream"
+ writeChan c_ $ XIEConnectionSucceeded
+ return s
+
+ -- We have received on an authenticated secure stream; we are
+ -- now ready to start processing client events
+ processEvent (IEX (XEFeatures _))
+ | connectionState == ConnectedTLSSecured tlsCtx = do
+ loggerLog l (Just ("Session", "processEvent")) Debug $
+ "processEvent: Received features ([...]) on an authenticated sec" ++
+ "ure stream"
+ loggerLog l (Just ("Session", "processEvent")) Info $ "processEvent: User has successfully logged in"
+ case resource of
+ Nothing -> do
+ sendData tlsCtx $ DBLC.pack $ encodeString
+ ""
+ return ()
+ _ -> do
+ loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Setting resource: " ++
+ (fromJust resource)
+ sendData tlsCtx $ DBLC.pack $ encodeString
+ "" ++ fromJust resource ++
+ ""
+ return ()
+ r <- getID
+ sendData tlsCtx $ DBLC.pack $ encodeString $
+ "" ++
+ ""
+ writeChan c_ $ XIEAuthenticationSucceeded
+ return (s { stateAuthenticationState = Authenticated })
+
+ -- We have received a SASL challenge on a secure stream
+ processEvent (IEX (XEChallenge (Chal challenge)))
+ | connectionState == ConnectedTLSSecured tlsCtx = do
+ let challenge' = CBBS.decode challenge
+ case authenticationState of
+ AuthRequested -> do
+ -- This is the first challenge - we need to calculate the reply
+ loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Received initial challenge: " ++
+ challenge ++ " (or " ++ challenge' ++ ")"
+ random <- getID -- TODO: Length and content.
+ case replyToChallenge1 challenge' serverHost (fromJust userName)
+ (fromJust password) random of
+ Left reply -> do
+ let reply' = (filter (/= '\n') (CBBS.encode reply))
+ loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Sending challenge response: " ++
+ reply'
+ sendData tlsCtx $ DBLC.pack $ encodeString $
+ "" ++
+ reply' ++ ""
+ return (s { stateAuthenticationState = Challenge1Processed } )
+ Right error -> do
+ putStrLn $ show error
+ return s
+ Challenge1Processed -> do
+ -- This is not the first challenge; [...]
+ -- TODO: Can we assume "rspauth"?
+ loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Received non-initial challenge: " ++
+ challenge ++ " (or " ++ challenge' ++ ")"
+ liftIO $ sendData tlsCtx $ DBLC.pack $ encodeString $
+ ""
+ return s
+
+ -- We have received a SASL "success" message over a secured connection
+ -- TODO: Parse the success message?
+ -- TODO: ?
+ processEvent (IEX (XESuccess (Succ _)))
+ | connectionState == ConnectedTLSSecured tlsCtx = do
+ loggerLog l (Just ("Session", "processEvent")) Debug $
+ "processEvent: Received authentication success: [...]; restartin" ++
+ "g stream" -- TODO
+ sendData tlsCtx $ DBLC.pack $
+ encodeString ""
+ return s { stateAuthenticationState = Authenticated }
+
+ -- Ignore id="bind_1" and session IQ result, otherwise create client event
+ processEvent (IEX (XEIQ iqEvent))
+ | authenticationState == Authenticated = do
+ case shouldIgnoreIQ iqEvent of
+ True ->
+ return s
+ False -> do
+ loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Got IQ for client: " ++
+ (show iqEvent)
+ writeChan c_ $ XIEIQ iqEvent
+ return s
+
+ processEvent (IEX (XEPresence presenceEvent))
+ | authenticationState == Authenticated = do
+ loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Got presence for client: " ++
+ (show presenceEvent)
+ writeChan c_ $ XIEPresence presenceEvent
+ return s
+
+ processEvent (IEX (XEMessage messageEvent)) = do
+ loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Got message for client: " ++
+ (show messageEvent)
+ writeChan c_ $ XIEMessage messageEvent
+ return s
+
+ -- We received an XML element that we didn't parse
+ processEvent (IEX xmlEvent) = do
+ loggerLog l (Just ("Session", "processEvent")) Warning $ "processEvent: XML event slipped through: " ++
+ (show xmlEvent)
+ return s
+
+ shouldIgnoreIQ :: IQ -> Bool
+ shouldIgnoreIQ i = case iqPayload i of
+ Nothing -> False
+ Just e -> case nameNamespace $ elementName e of
+ Just x | x == DT.pack "urn:ietf:params:xml:ns:xmpp-bind" -> True
+ Just x | x == DT.pack "urn:ietf:params:xml:ns:xmpp-session" -> True
+ Just _ -> False
+ Nothing -> False
+
+parseIQ :: Element -> IQ
+parseIQ e | typeAttr == "get" = let (Just payloadMust) = payload
+ in iqGet idAttr fromAttr toAttr Nothing
+ payloadMust
+ | typeAttr == "set" = let (Just payloadMust) = payload
+ in iqSet idAttr fromAttr toAttr Nothing
+ payloadMust
+ | typeAttr == "result" = iqResult idAttr fromAttr toAttr Nothing
+ payload
+
+ where
+ -- TODO: Many duplicate functions from parsePresence.
+
+ payload :: Maybe Element
+ payload = case null (elementChildren e) of
+ True -> Nothing
+ False -> Just $ head $ elementChildren e
+
+ typeAttr :: String
+ typeAttr = case attributeText typeName e of
+ -- Nothing -> Nothing
+ Just a -> DT.unpack a
+
+ fromAttr :: Maybe JID
+ fromAttr = case attributeText fromName e of
+ Nothing -> Nothing
+ Just a -> stringToJID $ DT.unpack a
+
+ toAttr :: Maybe JID
+ toAttr = case attributeText toName e of
+ Nothing -> Nothing
+ Just a -> stringToJID $ DT.unpack a
+
+ idAttr :: Maybe StanzaID
+ idAttr = case attributeText idName e of
+ Nothing -> Nothing
+ Just a -> Just (SID (DT.unpack a))
+
+ typeName :: Name
+ typeName = fromString "type"
+
+ fromName :: Name
+ fromName = fromString "from"
+
+ toName :: Name
+ toName = fromString "to"
+
+ idName :: Name
+ idName = fromString "id"
+
+-- TODO: Parse xml:lang
+
+parsePresence :: Element -> Presence
+parsePresence e = presence idAttr fromAttr toAttr Nothing typeAttr (elementChildren e)
+ where
+ -- TODO: Many duplicate functions from parseIQ.
+
+ typeAttr :: PresenceType
+ typeAttr = case attributeText typeName e of
+ Just t -> stringToPresenceType $ DT.unpack t
+ Nothing -> Available
+
+ fromAttr :: Maybe JID
+ fromAttr = case attributeText fromName e of
+ Nothing -> Nothing
+ Just a -> stringToJID $ DT.unpack a
+
+ toAttr :: Maybe JID
+ toAttr = case attributeText toName e of
+ Nothing -> Nothing
+ Just a -> stringToJID $ DT.unpack a
+
+ idAttr :: Maybe StanzaID
+ idAttr = case attributeText idName e of
+ Nothing -> Nothing
+ Just a -> Just (SID (DT.unpack a))
+
+ fromName :: Name
+ fromName = fromString "from"
+
+ typeName :: Name
+ typeName = fromString "type"
+
+ toName :: Name
+ toName = fromString "to"
+
+ idName :: Name
+ idName = fromString "id"
+
+parseMessage :: Element -> Message
+parseMessage e = message idAttr fromAttr toAttr Nothing typeAttr (elementChildren e)
+ where
+ -- TODO: Many duplicate functions from parseIQ.
+
+ typeAttr :: MessageType
+ typeAttr = case attributeText typeName e of
+ Just t -> stringToMessageType $ DT.unpack t
+ Nothing -> Normal
+
+ fromAttr :: Maybe JID
+ fromAttr = case attributeText fromName e of
+ Nothing -> Nothing
+ Just a -> stringToJID $ DT.unpack a
+
+ toAttr :: Maybe JID
+ toAttr = case attributeText toName e of
+ Nothing -> Nothing
+ Just a -> stringToJID $ DT.unpack a
+
+ idAttr :: Maybe StanzaID
+ idAttr = case attributeText idName e of
+ Nothing -> Nothing
+ Just a -> Just (SID (DT.unpack a))
+
+ fromName :: Name
+ fromName = fromString "from"
+
+ typeName :: Name
+ typeName = fromString "type"
+
+ toName :: Name
+ toName = fromString "to"
+
+ idName :: Name
+ idName = fromString "id"
+
+-- stringToPresenceType "available" = Available
+-- stringToPresenceType "away" = Away
+-- stringToPresenceType "chat" = Chat
+-- stringToPresenceType "dnd" = DoNotDisturb
+-- stringToPresenceType "xa" = ExtendedAway
+
+stringToPresenceType "probe" = Probe
+stringToPresenceType "error" = PresenceError
+
+stringToPresenceType "unavailable" = Unavailable
+stringToPresenceType "subscribe" = Subscribe
+stringToPresenceType "subscribed" = Subscribed
+stringToPresenceType "unsubscribe" = Unsubscribe
+stringToPresenceType "unsubscribed" = Unsubscribed
+
+-- presenceTypeToString Available = "available"
+
+-- presenceTypeToString Away = "away"
+-- presenceTypeToString Chat = "chat"
+-- presenceTypeToString DoNotDisturb = "dnd"
+-- presenceTypeToString ExtendedAway = "xa"
+
+presenceTypeToString Unavailable = "unavailable"
+
+presenceTypeToString Probe = "probe"
+presenceTypeToString PresenceError = "error"
+
+presenceTypeToString Subscribe = "subscribe"
+presenceTypeToString Subscribed = "subscribed"
+presenceTypeToString Unsubscribe = "unsubscribe"
+presenceTypeToString Unsubscribed = "unsubscribed"
+
+stringToMessageType "chat" = Chat
+stringToMessageType "error" = MessageError
+stringToMessageType "groupchat" = Groupchat
+stringToMessageType "headline" = Headline
+stringToMessageType "normal" = Normal
+stringToMessageType s = OtherMessageType s
+
+messageTypeToString Chat = "chat"
+messageTypeToString MessageError = "error"
+messageTypeToString Groupchat = "groupchat"
+messageTypeToString Headline = "headline"
+messageTypeToString Normal = "normal"
+messageTypeToString (OtherMessageType s) = s
+
+xmlEnumerator :: Chan InternalEvent -> Handle -> String -> Logger -> IO ()
+xmlEnumerator c h s l = do
+ loggerLog l (Just ("Session", "processEvent")) Debug $ "xmlEnumerator: Starting to read insecure XML"
+ run_ $ enumHandle 1 h $$ joinI $ parseBytes decodeEntities
+ $$ xmlReader c [] 0
+ loggerLog l (Just ("Session", "processEvent")) Debug $ "xmlEnumerator: Unsecure stream ended - performing TLS handshake"
+ t <- handshake' h s
+ case t of
+ Just tlsctx -> do loggerLog l (Just ("Session", "processEvent")) Debug $ "xmlEnumerator: Handshake successful - st" ++
+ "arting to read secure XML"
+ writeChan c (IES (TLSSucceeded tlsctx))
+ run_ $ enumTLS tlsctx $$ joinI $ parseBytes decodeEntities
+ $$ xmlReader c [] 0
+ loggerLog l (Just ("Session", "processEvent")) Debug $
+ "xmlEnumerator: Secure stream ended, exiting"
+ return ()
+ Nothing -> loggerLog l (Just ("Session", "processEvent")) Debug $ "xmlEnumerator: TLS handshake failed" -- TODO: Event
+ return ()
+
+enumTLS :: TLSCtx -> E.Enumerator DB.ByteString IO b
+enumTLS c s = loop c s where
+ loop :: TLSCtx -> E.Step DB.ByteString IO b -> E.Iteratee DB.ByteString IO b
+ loop c (E.Continue k) =
+ do d <- recvData c
+ case DBL.null d of
+ True -> loop c (E.Continue k)
+ False -> k (E.Chunks $ DBL.toChunks d) E.>>== loop c
+ loop _ step = E.returnI step
+
+hPutStr' :: Handle -> String -> IO ()
+hPutStr' h s = do
+ hPutStr h $ encodeString ""
+ 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
+ | nameLocalName name == DT.pack "message" = XEMessage $ parseMessage $ eventsToElement e
+ | otherwise = XEOther $ elementToString $ Just (eventsToElement e)
+ where
+ (EventBeginElement name attribs) = head e
+ es = tail e
+
+eventsToElement :: [Event] -> Element
+eventsToElement e = do
+ documentRoot $ fromJust (run_ $ enum e $$ fromEvents)
+ where
+ enum :: [Event] -> E.Enumerator Event Maybe Document
+ enum e_ (E.Continue k) = k $ E.Chunks e_
+ enum e_ step = E.returnI step
+
+counter :: Int -> Maybe Event -> Int
+counter c (Just (EventBeginElement _ _)) = (c + 1)
+counter c (Just (EventEndElement _) ) = (c - 1)
+counter c _ = c
+
+presenceToXML :: Presence -> String
+presenceToXML p = "" ++
+ (elementsToString $ presencePayload p) ++ ""
+ where
+ s = presenceStanza p
+
+ from :: String
+ from = case stanzaFrom $ presenceStanza p of
+ -- TODO: Lower-case
+ Just s -> " from='" ++ (jidToString s) ++ "'"
+ Nothing -> ""
+
+ id' :: String
+ id' = case stanzaID s of
+ Just (SID s) -> " id='" ++ s ++ "'"
+ Nothing -> ""
+
+ to :: String
+ to = case stanzaTo $ presenceStanza p of
+ -- TODO: Lower-case
+ Just s -> " to='" ++ (jidToString s) ++ "'"
+ Nothing -> ""
+
+ type' :: String
+ type' = case presenceType p of
+ Available -> ""
+ t -> " type='" ++ (presenceTypeToString t) ++ "'"
+
+iqToXML :: IQ -> String
+iqToXML IQGet { iqGetStanza = s, iqGetPayload = p } =
+ let type' = " type='get'" in "" ++ (elementToString (Just p)) ++ ""
+ where
+ from :: String
+ from = case stanzaFrom s of
+ -- TODO: Lower-case
+ Just s -> " from='" ++ (jidToString s) ++ "'"
+ Nothing -> ""
+
+ id' :: String
+ id' = case stanzaID s of
+ Just (SID s) -> " id='" ++ s ++ "'"
+ Nothing -> ""
+
+ to :: String
+ to = case stanzaTo s of
+ -- TODO: Lower-case
+ Just s -> " to='" ++ (jidToString s) ++ "'"
+ Nothing -> ""
+
+iqToXML IQSet { iqSetStanza = s, iqSetPayload = p } =
+ let type' = " type='set'" in "" ++ (elementToString (Just p)) ++ ""
+ where
+ from :: String
+ from = case stanzaFrom s of
+ -- TODO: Lower-case
+ Just s -> " from='" ++ (jidToString s) ++ "'"
+ Nothing -> ""
+
+ id' :: String
+ id' = case stanzaID s of
+ Just (SID s) -> " id='" ++ s ++ "'"
+ Nothing -> ""
+
+ to :: String
+ to = case stanzaTo s of
+ -- TODO: Lower-case
+ Just s -> " to='" ++ (jidToString s) ++ "'"
+ Nothing -> ""
+
+iqToXML IQResult { iqResultStanza = s, iqResultPayload = p } =
+ let type' = " type='result'" in "" ++ (elementToString p) ++ ""
+ where
+ from :: String
+ from = case stanzaFrom s of
+ -- TODO: Lower-case
+ Just s -> " from='" ++ (jidToString s) ++ "'"
+ Nothing -> ""
+
+ id' :: String
+ id' = case stanzaID s of
+ Just (SID s) -> " id='" ++ s ++ "'"
+ Nothing -> ""
+
+ to :: String
+ to = case stanzaTo s of
+ -- TODO: Lower-case
+ Just s -> " to='" ++ (jidToString s) ++ "'"
+ Nothing -> ""
+
+messageToXML :: Message -> String
+messageToXML m = "" ++
+ (elementsToString $ messagePayload m) ++ ""
+ where
+ s = messageStanza m
+
+ from :: String
+ from = case stanzaFrom $ messageStanza m of
+ -- TODO: Lower-case
+ Just s -> " from='" ++ (jidToString s) ++ "'"
+ Nothing -> ""
+
+ id' :: String
+ id' = case stanzaID s of
+ Just (SID s) -> " id='" ++ s ++ "'"
+ Nothing -> ""
+
+ to :: String
+ to = case stanzaTo $ messageStanza m of
+ -- TODO: Lower-case
+ Just s -> " to='" ++ (jidToString s) ++ "'"
+ Nothing -> ""
+
+ type' :: String
+ type' = case messageType m of
+ Normal -> ""
+ t -> " type='" ++ (messageTypeToString t) ++ "'"
diff --git a/Network/XMPP/Stanza.hs b/Network/XMPP/Stanza.hs
new file mode 100644
--- /dev/null
+++ b/Network/XMPP/Stanza.hs
@@ -0,0 +1,237 @@
+-- | Module: $Header$
+-- Description: XMPP stanza types and utility functions
+-- Copyright: Copyright © 2010-2011 Jon Kristensen
+-- License: BSD-3
+--
+-- Maintainer: info@pontarius.org
+-- Stability: unstable
+-- Portability: portable
+--
+-- This module will be documented soon.
+
+-- Received stanzas can be assumed to have their ID and to fields set.
+
+-- TODO: Handle error stanzas
+
+module Network.XMPP.Stanza ( StanzaID (SID)
+ , From
+ , To
+ , XMLLang
+ , Stanza (..)
+ , MessageType (..)
+ , Message (..)
+ , message
+ , PresenceType (..)
+ , Presence (..)
+ , presence
+ , IQ (..)
+ , iqGet
+ , iqSet
+ , iqResult
+ , iqStanza
+ , iqPayloadNamespace
+ , iqPayload ) where
+
+import Network.XMPP.JID
+
+import Data.XML.Types
+import qualified Data.Text as DT
+
+
+data StanzaID = SID String deriving (Eq, Show)
+type From = JID
+type To = JID
+type XMLLang = String -- Validate, protect
+
+
+data Stanza = Stanza { stanzaID :: Maybe StanzaID
+ , stanzaFrom :: Maybe From
+ , stanzaTo :: Maybe To
+ , stanzaLang :: Maybe XMLLang } deriving (Eq, Show)
+
+
+stanza :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang -> Stanza
+
+stanza i f t l = Stanza { stanzaID = i
+ , stanzaFrom = f
+ , stanzaTo = t
+ , stanzaLang = l }
+
+
+data MessageType = Chat |
+ MessageError |
+ Groupchat |
+ Headline |
+ Normal | -- Default
+ OtherMessageType String deriving (Eq, Show)
+
+
+data Message = Message { messageStanza :: Stanza
+ , messageType :: MessageType
+ , messagePayload :: [Element] } deriving (Eq, Show)
+
+
+message :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang ->
+ MessageType -> [Element] -> Message
+
+message i f t l t_ p = Message { messageStanza = stanza i f t l
+ , messageType = t_
+ , messagePayload = p }
+
+
+data PresenceType = Subscribe | -- ^ Sender wants to subscribe to presence
+ Subscribed | -- ^ Sender has approved the subscription
+ Unsubscribe | -- ^ Sender is unsubscribing from presence
+ Unsubscribed | -- ^ Sender has denied or cancelled a
+ -- subscription
+ Probe | -- ^ Sender requests current presence;
+ -- should only be used by servers
+ PresenceError | -- ^ Processing or delivery of previously
+ -- sent presence stanza failed
+ Available | -- Not part of type='' [...]
+ -- Away |
+ -- Chat |
+ -- DoNotDisturb |
+ -- ExtendedAway |
+ Unavailable
+ deriving (Eq, Show)
+
+
+-- | Presence stanzas are used to express an entity's network availability.
+
+data Presence = Presence { presenceStanza :: Stanza
+ , presenceType :: PresenceType
+ , presencePayload :: [Element] } deriving (Eq, Show)
+
+
+presence :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang ->
+ PresenceType -> [Element] -> Presence
+
+presence i f t l t_ p = Presence { presenceStanza = Stanza { stanzaID = i
+ , stanzaFrom = f
+ , stanzaTo = t
+ , stanzaLang = l }
+ , presenceType = t_
+ , presencePayload = p }
+
+
+data IQ = IQGet { iqGetStanza :: Stanza, iqGetPayload :: Element } |
+ IQSet { iqSetStanza :: Stanza, iqSetPayload :: Element } |
+ IQResult { iqResultStanza :: Stanza
+ , iqResultPayload :: Maybe Element } deriving (Eq, Show)
+
+
+iqGet :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang -> Element ->
+ IQ
+
+iqGet i f t l p = IQGet { iqGetStanza = Stanza { stanzaID = i
+ , stanzaFrom = f
+ , stanzaTo = t
+ , stanzaLang = l }
+ , iqGetPayload = p }
+
+
+iqSet :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang -> Element ->
+ IQ
+
+iqSet i f t l p = IQSet { iqSetStanza = Stanza { stanzaID = i
+ , stanzaFrom = f
+ , stanzaTo = t
+ , stanzaLang = l }
+ , iqSetPayload = p }
+
+
+iqResult :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe XMLLang ->
+ Maybe Element -> IQ
+
+iqResult i f t l p = IQResult { iqResultStanza = Stanza { stanzaID = i
+ , stanzaFrom = f
+ , stanzaTo = t
+ , stanzaLang = l }
+ , iqResultPayload = p }
+
+
+iqStanza :: IQ -> Stanza
+iqStanza (IQGet { iqGetStanza = s }) = s
+iqStanza (IQSet { iqSetStanza = s }) = s
+iqStanza (IQResult { iqResultStanza = s }) = s
+
+iqPayload :: IQ -> Maybe Element
+iqPayload (IQGet {iqGetPayload = p}) = Just p
+iqPayload (IQSet {iqSetPayload = p}) = Just p
+iqPayload (IQResult {iqResultPayload = p}) = p
+
+iqPayloadNamespace :: IQ -> Maybe String
+iqPayloadNamespace i = case iqPayload i of
+ Nothing -> Nothing
+ Just p -> case nameNamespace $ elementName p of
+ Nothing -> Nothing
+ Just n -> Just (DT.unpack n)
+
+
+-- =============================================================================
+-- CODE NOT YET USED
+-- =============================================================================
+
+
+-- | All stanzas (IQ, message, presence) can cause errors, which looks like
+-- . These errors are of one of the
+-- types listed below.
+
+data StanzaErrorType = Cancel | -- ^ Error is unrecoverable - do not retry
+ Continue | -- ^ Conditition was a warning - proceed
+ Modify | -- ^ Change the data and retry
+ Auth | -- ^ Provide credentials and retry
+ Wait -- ^ Error is temporary - wait and retry
+ deriving (Eq, Show)
+
+
+-- | The stanza errors are accommodated with one of the error conditions listed
+-- below. The ones that are not self-explainatory should be documented below.
+
+data StanzaErrorCondition = BadRequest | -- ^ Malformed XML
+ Conflict | -- ^ Resource or session
+ -- with name already
+ -- exists
+ FeatureNotImplemented |
+ Forbidden | -- ^ Insufficient
+ -- permissions
+ Gone | -- ^ Entity can no longer
+ -- be contacted at this
+ -- address
+ InternalServerError |
+ ItemNotFound |
+ JIDMalformed |
+ NotAcceptable | -- ^ Does not meet policy
+ -- criteria
+ NotAllowed | -- ^ No entity may perform
+ -- this action
+ NotAuthorized | -- ^ Must provide proper
+ -- credentials
+ PaymentRequired |
+ RecipientUnavailable | -- ^ Temporarily
+ -- unavailable
+ Redirect | -- ^ Redirecting to other
+ -- entity, usually
+ -- temporarily
+ RegistrationRequired |
+ RemoteServerNotFound |
+ RemoteServerTimeout |
+ ResourceConstraint | -- ^ Entity lacks the
+ -- necessary system
+ -- resources
+ ServiceUnavailable |
+ SubscriptionRequired |
+ UndefinedCondition | -- ^ Application-specific
+ -- condition
+ UnexpectedRequest -- ^ Badly timed request
+ deriving (Eq, Show)
+
+
+-- IM/RFC:
+-- data PresenceStatus = PS String deriving (Eq, Show)
+
+-- -- TODO: Validate input.
+
+-- presenceStatus :: String -> Maybe PresenceStatus
+-- presenceStatus s = Just (PS s)
diff --git a/Network/XMPP/Utilities.hs b/Network/XMPP/Utilities.hs
new file mode 100644
--- /dev/null
+++ b/Network/XMPP/Utilities.hs
@@ -0,0 +1,109 @@
+-- | Module: $Header$
+-- Description: Utility functions for Pontarius XMPP; currently only random ID
+-- generation functions
+-- Copyright: Copyright © 2010-2011 Jon Kristensen
+-- License: BSD-3
+--
+-- Maintainer: info@pontarius.org
+-- Stability: unstable
+-- Portability: portable
+--
+-- This module will be documented soon.
+
+-- TODO: Document this module
+-- TODO: Make is possible to customize characters
+-- TODO: Make it possible to customize length
+
+module Network.XMPP.Utilities ( elementToString
+ , elementsToString
+ , getID
+ , getID_) where
+
+import Data.Word
+import Data.XML.Types
+import System.Crypto.Random
+import System.Random
+import qualified Data.ByteString as DB
+import qualified Data.Map as DM
+import qualified Data.Text as DT
+
+
+
+-- =============================================================================
+-- ID Generation
+-- =============================================================================
+
+
+characters :: String
+characters = "abcdef0123456789"
+
+getID :: IO String
+getID = getID_ 8
+
+getID_ :: Int -> IO String
+getID_ i =
+ do se <- getSeed
+ let st = mkStdGen se
+ return $ take i (idSequence st)
+ where
+ idSequence :: StdGen -> String
+ idSequence st = [characters !! (fst $ rand st)] ++ idSequence (snd $ rand st)
+ rand :: StdGen -> (Int, StdGen)
+ rand st = randomR (0, length characters - 1) st
+
+getSeed :: IO Int
+getSeed =
+ do h <- openHandle
+ b <- hGetEntropy h 8
+ let w = DB.unpack b
+ let s = seed w
+ closeHandle h
+ return s
+ where seed :: [Word8] -> Int
+ seed [] = 1
+ seed (x:xs) = ((fromIntegral x) + 1) * (seed xs)
+
+
+
+-- =============================================================================
+-- XML Utilities
+-- =============================================================================
+
+
+elementsToString :: [Element] -> String
+elementsToString [] = ""
+elementsToString (e:es) = (elementToString $ Just e) ++ elementsToString es
+
+elementToString :: Maybe Element -> String
+elementToString Nothing = ""
+elementToString (Just e) = "<" ++ nameToString (elementName e) ++ xmlns ++
+ attributes (DM.toList (elementAttributes e)) ++
+ ">" ++ (nodesToString $ elementNodes e) ++ ""
+ 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
--- a/README
+++ b/README
@@ -1,25 +1,21 @@
Pontarius XMPP aims to be a secure and easy-to-use XMPP library for Haskell. We
-have just released a second alpha version with the following features:
+have just released a third alpha version with the following features:
* Client-to-server Transport Layer Security and DIGEST-MD5 SASL Authentication
- * Concurrent and Event-based API for XMPP Client Developers
- * Support for Info/Query and Presence Stanzas
+ * Concurrent, Flexible and Event-based API for XMPP Client Developers
+ * Support for Info/Query, Presence and Message Stanzas
* Interoperable XML Parsing (Using enumerator, xml-enumerator and xml-types)
Please note that we are not recommending anyone to use Pontarius XMPP at this
time as it’s still in an experimental stage and will have its API and data types
-modified frequently. We have scheduled the first beta release for the 4th of
-May. That being said, if you are interested to use Pontarius XMPP anyway, feel
-free to contact the Pontarius project and we will try to help you get started.
+modified. However, if you are interested to use Pontarius XMPP anyway, feel free
+to contact the Pontarius project and we will try to help you get started. You
+can also see the Example directory for a usage example.
We are currently working on general improvements, securing the client-to-client
-communication and having the library support all of RFC 3920: XMPP Core (by for
-example supporting message stanzas).
-
-We will release the next version, 0.1 Alpha 3, on the 13th of April.
+communication and having the library support all of RFC 3920: XMPP Core.
-Check pontarius-xmpp.cabal for dependency information if you want to build
-Pontarius XMPP by hand.
+We will release the next version, 0.1 Alpha 4, on the 4th of May.
Look at the Pontarius web site , the Pontarius XMPP
web page and the Pontarius
diff --git a/Test.hs b/Test.hs
deleted file mode 100644
--- a/Test.hs
+++ /dev/null
@@ -1,35 +0,0 @@
--- module Test where
-
-import Control.Concurrent.Chan (Chan, readChan, writeChan)
-import Network.XMPP.PontariusXMPP
-import Data.XML.Types
-import qualified Data.Text as DT
-import Data.Maybe
-
-host = "test.pontarius.org"
-user = "sprint1"
-server = "test.pontarius.org"
-port = 5222
-resource = "pontarius"
-password = ""
-
-main :: IO ()
-main =
- do (co, ci) <- connect host port -- TODO: In, Out
- (jid (Just user) server (Just resource)) password
- writeChan co $ presenceEvent DoNotDisturb (presenceStatus "Pontarius XMPP 0.1 Alpha 2 Test")
- loop ci
-
-loop :: Chan ClientInEvent -> IO ()
-loop c =
- do e <- readChan c
- processEvent e
- loop c
-
- where
- processEvent :: ClientInEvent -> IO ()
- processEvent (CIEIQGet (i, f, t, e))
- | (nameNamespace $ elementName e) /= Nothing &&
- (DT.unpack $ fromJust (nameNamespace $ elementName e)) ==
- "http://jabber.org/protocol/disco#info" = putStrLn "Disco info!"
- | otherwise = putStrLn $ ">>>>>>>>>> " ++ (show e)
diff --git a/XTLS.hs b/XTLS.hs
new file mode 100644
--- /dev/null
+++ b/XTLS.hs
@@ -0,0 +1,75 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+
+module XTLS (start) where
+
+import Network.XMPP
+import Control.Concurrent (forkIO)
+import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
+
+import Data.XML.Types
+import Network.XMPP.Stanza
+import Control.Monad ((>=>))
+import Data.Maybe
+
+data State = State {}
+
+start :: IO ()
+start = putStrLn "Test"
+
+stateLoop :: State -> Chan XMPPInEvent -> Chan XMPPOutEvent -> IO ()
+stateLoop s c c_ = do
+ e <- readChan c
+ s' <- processEvent e s c_
+ stateLoop s' c c_
+
+processEvent :: XMPPInEvent -> State -> Chan XMPPOutEvent -> IO State
+-- processEvent (PATTERN_MATCHING) s c = do
+-- return s
+processEvent (XIEIQ iq) s c = do
+ -- putStrLn
+ case xtlsOrJingle iq of
+ 'j' -> return s
+ 'x' -> return s
+ 'n' -> return s
+
+xtlsOrJingle :: IQ -> Char
+xtlsOrJingle iq =
+ case iqPayloadNamespace iq of
+ Just "urn:xmpp:jingle:1" ->
+ case isXTLS $ head $ getContent (fromJust $ iqPayload iq) of
+ [] -> 'j'
+ other -> 'x'
+ other -> 'n'
+ where
+ isXTLS :: Element -> [Element]
+ isXTLS = elementChildren >=> isNamed xtlsName
+
+ getContent :: Element -> [Element]
+ getContent = elementChildren >=> isNamed "content"
+
+
+xtlsName :: Name
+xtlsName = ( "{urn:xmpp:jingle:security:xtls:0}security" :: Name )
+
+-- Jingle Event base on the XEP-166
+data JingleEvent = ContentAccept | ContentAdd | ContentModify | ContentReject |
+ ContentRemove | DiscriptionInfo | TransportAccept |
+ TransportInfo | TransportReject | TransportReplace
+
+data JingleSession = Initiated { sid :: String , candidate :: [Candidate] } |
+ Accepted { sid :: String , candidate :: [Candidate] } |
+ Media { sid :: String } |
+ Terminated { sid :: String }
+
+data Candidate = Candidate { id :: Int ,
+ ip :: String ,
+ portNum :: Int ,
+ priority :: Int }
+
+data Transport = IBB { transid :: String , blockSize :: Int} |
+ OBB { transid :: String } -- TODO : define the OBB
+
+
+data XTLSSecurity = XTLSSecurity { fingerPrint :: String , methods :: [MethodName]}
+data MethodName = SRP | X509
diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal
--- a/pontarius-xmpp.cabal
+++ b/pontarius-xmpp.cabal
@@ -2,7 +2,7 @@
-- TODO: Highlighting bug: The last line of the description.
Name: pontarius-xmpp
-Version: 0.0.2.0
+Version: 0.0.3.0
Cabal-Version: >= 1.6
Build-Type: Simple
License: BSD3
@@ -13,8 +13,8 @@
Stability: alpha
Homepage: http://www.pontarius.org/projects/pontarius-xmpp/
Bug-Reports: mailto:info@pontarius.org
-Package-URL: http://www.pontarius.org/releases/pontarius-xmpp-0.0.2.0.tar.gz
-Synopsis: A (prototyped) easy to use XMPP library
+Package-URL: http://www.pontarius.org/releases/pontarius-xmpp-0.0.3.0.tar.gz
+Synopsis: A (prototyped) secure and easy to use XMPP library
Description: A work in progress of an implementation of RFC 3920: XMPP
Core.
Category: Network
@@ -25,12 +25,15 @@
-- Extra-Tmp-Files:
Library
- Exposed-Modules: Network.XMPP.PontariusXMPP
+ Exposed-Modules: Network.XMPP, Network.XMPP.JID, Network.XMPP.SASL,
+ Network.XMPP.Session, Network.XMPP.Stanza,
+ Network.XMPP.Utilities
Exposed: True
- Build-Depends: hlogger ==0.0.2.0, base >= 2 && < 5, enumerator,
+ Build-Depends: hlogger ==0.0.3.0, base >= 2 && < 5, enumerator,
crypto-api, base64-string, regex-posix, pureMD5,
utf8-string, network, xml-types, text, transformers,
- bytestring, binary, random, xml-enumerator, tls, containers
+ bytestring, binary, random, xml-enumerator, tls ==0.4.1,
+ containers
-- Other-Modules:
-- HS-Source-Dirs:
-- Extensions:
@@ -51,12 +54,13 @@
-- Pkgconfig-Depends:
-- Frameworks:
-Executable pontarius-xmpp-test
- Main-Is: Test.hs
- Build-Depends: hlogger ==0.0.2.0, base >= 2 && < 5, enumerator,
- crypto-api, base64-string, regex-posix, pureMD5,
- utf8-string, network, xml-types, text, transformers,
- bytestring, binary, random, xml-enumerator, tls, containers
+-- Executable pontarius-xmpp-test
+ -- Main-Is: Test.hs
+ -- Build-Depends: hlogger ==0.0.3.0, base >= 2 && < 5, enumerator,
+ -- crypto-api, base64-string, regex-posix, pureMD5,
+ -- utf8-string, network, xml-types, text, transformers,
+ -- bytestring, binary, random, xml-enumerator, tls ==0.4.1,
+ -- containers
-- Other-Modules:
-- HS-Source-Dirs:
-- Extensions:
@@ -87,5 +91,5 @@
Type: darcs
-- Module:
Location: https://patch-tag.com/r/jonkri/pontarius-xmpp
- Tag: 0.0.2.0
+ Tag: 0.0.3.0
-- Subdir: