HXMPP (empty) → 0.0.1.0
raw patch · 6 files changed
+1269/−0 lines, 6 filesdep +HLoggerdep +basedep +base64-stringsetup-changed
Dependencies added: HLogger, base, base64-string, binary, bytestring, crypto-api, enumerator, network, pureMD5, random, regex-posix, text, transformers, utf8-string, xml-enumerator, xml-types
Files
- HXMPP.cabal +91/−0
- HXMPP.hs +1107/−0
- HXMPPTest.hs +17/−0
- LICENSE +28/−0
- README +23/−0
- Setup.hs +3/−0
+ HXMPP.cabal view
@@ -0,0 +1,91 @@+-- TODO: Set dependency versions.+-- TODO: Highlighting bug: The last line of the description.++Name: HXMPP+Version: 0.0.1.0+Cabal-Version: >= 1.6+Build-Type: Simple+License: BSD3+License-File: LICENSE+Copyright: Copyright © 2011, Jon Kristensen+Author: Jon Kristensen, Mahdi Abdinejadi+Maintainer: jon.kristensen@pontarius.org+Stability: alpha+Homepage: http://www.pontarius.org/sub-projects/hxmpp/+Bug-Reports: mailto:info@pontarius.org+Package-URL: http://www.pontarius.org/releases/hxmpp-0.0.1.0.tar.gz+Synopsis: A (prototyped) easy to use XMPP library+Description: A work in progress of an implementation of RFC 3920: XMPP+ Core.+Category: Network+Tested-With: GHC ==6.12.3+-- Data-Files:+-- Data-Dir:+-- Extra-Source-Files:+-- Extra-Tmp-Files:++Library+ Exposed-Modules: HXMPP+ Exposed: True+ Build-Depends: HLogger ==0.0.1.0, base >= 2 && < 4, enumerator,+ crypto-api, base64-string, regex-posix, pureMD5,+ utf8-string, network, xml-types, text, transformers,+ bytestring, binary, random, xml-enumerator+ -- Other-Modules:+ -- HS-Source-Dirs:+ -- Extensions:+ -- Build-Tools:+ -- Buildable:+ -- GHC-Options:+ -- GHC-Prof-Options:+ -- Hugs-Options:+ -- NHC98-Options:+ -- Includes:+ -- Install-Includes:+ -- Include-Dirs:+ -- C-Sources:+ -- Extra-Libraries:+ -- Extra-Lib-Dirs:+ -- CC-Options:+ -- LD-Options:+ -- Pkgconfig-Depends:+ -- Frameworks:++Executable hxmpp-0.0.1.0-test+ Main-Is: HXMPPTest.hs+ Build-Depends: HLogger ==0.0.1.0, base >= 2 && < 4, enumerator,+ crypto-api, base64-string, regex-posix, pureMD5,+ utf8-string, network, xml-types, text, transformers,+ bytestring, binary, random, xml-enumerator+ -- Other-Modules:+ -- HS-Source-Dirs:+ -- Extensions:+ -- Build-Tools:+ -- Buildable:+ -- GHC-Options:+ -- GHC-Prof-Options:+ -- Hugs-Options:+ -- NHC98-Options:+ -- Includes:+ -- Install-Includes:+ -- Include-Dirs:+ -- C-Sources:+ -- Extra-Libraries:+ -- Extra-Lib-Dirs:+ -- CC-Options:+ -- LD-Options:+ -- Pkgconfig-Depends:+ -- Frameworks:++Source-Repository head+ Type: darcs+ -- Module:+ Location: https://patch-tag.com/r/jonkri/HXMPP+ -- Subdir:++Source-Repository this+ Type: darcs+ -- Module:+ Location: https://patch-tag.com/r/jonkri/HXMPP+ Tag: 0.0.1.0+ -- Subdir:
+ HXMPP.hs view
@@ -0,0 +1,1107 @@+-- | 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+-- +-- HXMPP aims to be an easy-to-use XMPP library for Haskell.+-- +-- We are not recommending anyone to use HXMPP 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 HXMPP anyway, feel free to+-- contact the Pontarius project and we will try to help you get started.+-- +-- This module will be thoroughly documented soon.++module HXMPP ( -- JID:+ JID+ , NodeIdentifier+ , ServerIdentifier+ , ResourceIdentifier+ , jidIsFull+ , jidIsBare+ , stringToJID+ , jidToString+ + -- Client API:+ , ClientEvent (..)+ , HXMPPEvent (..)+ , StanzaID+ , PresenceStatus+ , PresenceType (Available, Away, Chat, DoNotDisturb, ExtendedAway, Unavailable)+ , 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)+ , SubscribeType (Subscribe, Unsubscribe, Subscribed, Unsubscribed)+ , 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)+import Data.Enumerator (($$), Iteratee, Stream, Stream(Chunks), continue, joinI,+ run_, yield)+import Data.Enumerator.Binary (enumHandle, enumFile )+import qualified Data.Text.Lazy as DTL+import Data.XML.Types -- (Event)+import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput)+import HLogger+import Network+import System.IO (BufferMode, BufferMode(NoBuffering))+import Text.XML.Enumerator.Parse (parseBytes)+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)+import qualified Data.ByteString.Lazy.Char8 as DBLC (append, pack, unpack)+import Data.ByteString.Internal (c2w)++import qualified Data.Binary as DBi (Binary, encode)++import Data.Char (isLatin1)+import GHC.IO.Handle (hClose)+++-- TODO: Needs to be set manually for now.++getUsername = "username"+getPass = "password"+getHost = "host"+++-- =============================================================================+-- JID+-- =============================================================================+++-- | The node identifier is the part before the `@' character in Jabber IDs.+-- Node names are optional. 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.++type NodeIdentifier = String+++-- | 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. 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.++type ServerIdentifier = String+++-- | The resource identifier is the part after the `/' character in Jabber IDs.+-- Like with node names, the resource identifier is optional. 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.++type ResourceIdentifier = String+++-- | JIDs are written in the format of `node@server/resource'. 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'. 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 JID a data type instead, perhaps a record.++type JID = (Maybe NodeIdentifier, ServerIdentifier, Maybe ResourceIdentifier)+++-- | Converts a JID (tuple) to a String. For example, (Just "sprint5",+-- `test.pontarius.org', Just `pontarius-transfer' becomes+-- `sprint5@test.pontarius.org/pontarius-transfer'.++jidToString (Nothing, server, Nothing) = server+jidToString (Just node, server, Nothing) = node ++ "@" ++ server+jidToString (Nothing, server, Just resource) = server ++ "/" ++ resource+jidToString (Just node, server, Just resource) = node ++ "@" ++ server ++ "/" +++ resource+++-- | Converts a (JID) String to a JID (tuple). For example, "jonkri@jabber.org"+-- becomes (Just "jonkri", "jabber.org", Nothing).++-- TODO: Make the regular expression only match valid JIDs.+-- TODO: Use Perl regular expressions to use non-capturing groups with "(?:".++stringToJID :: String -> JID+stringToJID string = matchToJID $ string =~ "^(([^@]+)@)?([^/]+)(/(.+))?$"+ where+ matchToJID [[_, _, "", server, _, ""]] =+ (Nothing, server, Nothing)+ matchToJID [[_, _, node, server, _, ""]] =+ (Just node, server, Nothing)+ matchToJID [[_, _, "", server, _, resource]] =+ (Nothing, server, Just resource)+ matchToJID [[_, _, node, server, _, resource]] =+ (Just node, server, Just resource)+++-- | 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 (_, _, Nothing) = True+jidIsBare _ = 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++++-- =============================================================================+-- Client API+-- =============================================================================+++-- TODO: Presence priority.++-- | A StanzaID is a eight character string which you can either generate+-- yourself or have HXMPP generate for you.++data StanzaID = SID String deriving (Eq, Show)+++-- | All stanzas (IQ, message, presence) can cause errors, which looks like+-- <stanza-kind to='sender' type='error'>. These errors are of one of the+-- types listed below.++data StanzaErrorType = Cancel | -- ^ Error is unrecoverable - do not retry+ Continue | -- ^ Conditition was a warning - proceed+ Modify | -- ^ Change the data and retry+ Auth | -- ^ Provide credentials and retry+ Wait -- ^ Error is temporary - wait and retry+ deriving (Eq, Show)+++-- | The stanza errors are accommodated with one of the error conditions listed+-- below. The ones that are not self-explainatory should be documented below.++data StanzaErrorCondition = BadRequest | -- ^ Malformed XML+ Conflict | -- ^ Resource or session+ -- with name already+ -- exists+ FeatureNotImplemented |+ Forbidden | -- ^ Insufficient+ -- permissions+ Gone | -- ^ Entity can no longer+ -- be contacted at this+ -- address+ InternalServerError |+ ItemNotFound |+ JIDMalformed |+ NotAcceptable | -- ^ Does not meet policy+ -- criteria+ NotAllowed | -- ^ No entity may perform+ -- this action+ NotAuthorized | -- ^ Must provide proper+ -- credentials+ PaymentRequired |+ RecipientUnavailable | -- ^ Temporarily+ -- unavailable+ Redirect | -- ^ Redirecting to other+ -- entity, usually+ -- temporarily+ RegistrationRequired |+ RemoteServerNotFound |+ RemoteServerTimeout |+ ResourceConstraint | -- ^ Entity lacks the+ -- necessary system+ -- resources+ ServiceUnavailable |+ SubscriptionRequired |+ UndefinedCondition | -- ^ Application-specific+ -- condition+ UnexpectedRequest -- ^ Badly timed request+ deriving (Eq, Show)+++-- For messages, see http://www.ietf.org/rfc/rfc3921.txt, section 2.1.1.+-- data Message = Message { }+++-- | Presence stanzas are used to express an entity's network availability.++data SubscribeType = 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+ deriving (Eq, Show)+++-- TODO: Document the types.++data PresenceType = 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) }++-- (Chan ClientEvent, Chan HXMPPEvent)+connect :: String -> Integer -> JID -> String -> IO (Chan ClientEvent, Chan HXMPPEvent)+connect s po (u, _, r) pa = do+ ha <- connectTo s (PortNumber $ fromInteger po)+ hSetBuffering ha NoBuffering+ hPutStr ha $ encodeString "<?xml version='1.0'?><stream:stream to='" ++ s +++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams'" +++ " version='1.0'>"+ hFlush ha+ -- logInfo l "Start to parse the XML contents on the handle..."+ cc <- newChan+ ch <- newChan+ forkIO $ readEvents ha cc+ forkIO $ do run_ $ enumHandle 1 ha $$ joinI $ parseBytes $$+ loop State { parsingContext = PreDocument, stateServer = s, statePort = po } [] 0 ha ch+ return ()+ return (cc, ch)++readEvents ha ch = do+ threadDelay 3000000+ hPutStr ha $ encodeString "<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:params:xml:ns:xmpp-bind\"><resource>hxmpp</resource></bind></iq>"+ threadDelay 2000000+ hPutStr ha $ encodeString "<presence><priority>5</priority></presence>"+ threadDelay 2000000+ e <- readChan ch+ let s = clientEventToXML e+ putStrLn "888888888888888888888888888888888888888888888888888888888888888888"+ putStrLn s+ putStrLn "888888888888888888888888888888888888888888888888888888888888888888"+ hPutStr ha $ encodeString s+ readEvents ha ch++-- both presenceEvent and subscriptionEvent are presence stanzas+presenceEvent :: PresenceType -> Maybe PresenceStatus -> ClientEvent+presenceEvent t s = CEPresence (t, s)++-- subscriptionEvent :: Maybe StanzaID -> JID -> SubscribeType -> ClientEvent+-- subscriptionEvent i t j = CESubscription (i, t, j)++-- id, to, payload+iqGetEvent :: Maybe StanzaID -> Maybe JID -> Element -> ClientEvent+iqGetEvent i j p = CEIQGet (i, j, p)++iqSetEvent :: Maybe StanzaID -> Maybe JID -> Element -> ClientEvent+iqSetEvent i j p = CEIQSet (i, j, p)++iqResultEvent :: Maybe StanzaID -> JID -> Maybe Element -> ClientEvent+iqResultEvent i j p = CEIQResult (i, j, p)++iqErrorEvent :: Maybe StanzaID -> JID -> Element -> Maybe Element ->+ StanzaErrorType -> StanzaErrorCondition -> ClientEvent+iqErrorEvent i j p a t c = CEIQError (i, j, p, a, t, c)++disconnectEvent :: ClientEvent+disconnectEvent = CEDisconnect++data ClientEvent = CEPresence (PresenceType, Maybe PresenceStatus) |+ -- CESubscription (Maybe StanzaID, JID, SubscribeType) |+ CEIQGet (Maybe StanzaID, Maybe JID, Element) |+ CEIQSet (Maybe StanzaID, Maybe JID, Element) |+ CEIQResult (Maybe StanzaID, JID, Maybe Element) |+ CEIQError (Maybe StanzaID, JID, Element, Maybe Element,+ StanzaErrorType, StanzaErrorCondition) |+ CEDisconnect deriving (Eq, Show)+++data HXMPPEvent = HEConnected |+ HEPresence (Maybe StanzaID, Maybe JID, Maybe JID,+ PresenceType, [Element]) |+ HEIQGet (Maybe StanzaID, Maybe JID, Maybe JID, Element) |+ HEIQSet (StanzaID, Maybe JID, Maybe JID, Element) |+ HEIQResult (StanzaID, Maybe JID, Maybe JID, Maybe Element) |+ -- HEIQError (StanzaID, JID, Element, Maybe Element,+ -- StanzaErrorType, StanzaErrorCondition) | -- TODO+ HEDisconnected deriving (Eq, Show)++++-- =============================================================================+-- Temporary+-- =============================================================================+++data Stanza = StanzaIQ IQ | StanzaPresence Presence -- StanzaMessage Message++data UnknownMechanism = UM String++-- TODO: Add namespace?++data FeaturesMechanism = DigestMD5 | CramMD5 | Login | Plain | UnknownMechanism++data CompressionMethod = Zlib++-- TODO: Add support for `ver optional'.+data Features = Features { featuresStartTLS :: Bool+ , featuresMechanisms :: [FeaturesMechanism]+ , featuresCompressionMethods :: [CompressionMethod] }++featuresDefault = Features { featuresStartTLS = False,+ featuresMechanisms = [],+ featuresCompressionMethods = []}++-- Stream elements are first-level elements of the XMPP XML stream. They are+-- (so far) either stanzas or stream features.+data StreamElement = SEStanza Stanza | SEFeatures Features++-- 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 IQGet = IQGet { iqGetID :: StanzaID+ , iqGetFrom :: JID+ , iqGetTo :: JID -- TODO: Maybe?+ , iqGetPayload :: Element }++data IQSet = IQSet { iqSetID :: StanzaID+ , iqSetFrom :: JID+ , iqSetTo :: Maybe JID+ , iqSetPayload :: Element }++data IQResult = IQResult { iqResultID :: StanzaID+ , iqResultFrom :: JID+ , iqResultTo :: JID+ , iqResultPayload :: Maybe Element }++-- | 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 }++data IQ = IQG IQGet | IQS IQSet | IQR IQResult | IRE IQError+++getAuth = "<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='DIGEST-MD5'/>"++-- ---------------------------------------------------------------------------+data ParsingContext = PreDocument -- No xml stream received+ | Authenticating -- Received xml stream and negotiate for+ -- stream features+ | Challenge -- Send Challenge to server and recieve..+ | Authenticated -- Conected to Jabber server+ | Disconnected -- Disconected to Jabber server+ deriving Eq++data State = State { parsingContext :: ParsingContext+ , stateServer :: String+ , statePort :: Integer }+-- main :: IO ()+-- main =+-- do l <- startLogger "HXMPP"+-- logNotice l "HXMPP started."+-- connect getHost getPort (stringToJID (getUsername ++ "@" ++ getHost ++ "/hxmpp")) getPass+-- stopLogger l+++-- start :: String -> Integer -> HLoggerState -> IO ()+-- start ho p l = withSocketsDo $ do+-- logNotice l ("Connecting to " ++ ho ++ ":" ++ (show p) ++ "...")+-- ha <- connectTo ho (PortNumber $ fromInteger p)+-- hSetBuffering ha NoBuffering+-- hPutStr ha $ encodeString "<?xml version='1.0'?><stream:stream to='" ++ ho +++-- "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams'" +++-- " version='1.0'>"+-- hFlush ha+-- logInfo l "Start to parse the XML contents on the handle..."+-- -- es <- myParser+-- -- putStrLn "Passed"+-- -- featureHandler es+-- run_ $ enumHandle 1 ha $$ joinI $+-- parseBytes $$ loop State { parsingContext = PreDocument, stateServer = ho, statePort = p } [] 0 ha c+-- return ()++-- myParser :: IO [Event]+-- myParser = do+-- r <- D.readFile "XML.txt"+-- case r of+-- Right d -> return $ D.toEvents d+-- _ -> return []++myEnum :: (Monad m) => [Event] -> E.Enumerator Event m Document+myEnum es (E.Continue k) = k $ 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++-- TODO: Add validity checker?+loop :: State -> [Event] -> Int -> Handle -> Chan HXMPPEvent -> Iteratee Event IO (Maybe Event)+-- Check for the first bunch of Events which contains stream features.+loop (State { parsingContext = Authenticating }) ((EventEndElement n):xs) 1 ha c =+ do+ s' <- liftIO $ featureHandler ha $ DL.reverse ((EventEndElement n):xs)+ liftIO $ putStrLn "************Send an Event for connecting...."+ loop s' [] 1 ha c++-- Check for the first bunch of challenge+loop (State { parsingContext = Challenge }) ((EventEndElement n):xs) 1 ha c =+ do+ liftIO $ callEvent $ DL.reverse ((EventEndElement n):xs)+ i <- liftIO $ processChall ha $ DL.reverse ((EventEndElement n):xs)+ case i of+ 1 -> do+ liftIO $ putStrLn "************Send a Challenge...."+ loop State { parsingContext = Challenge, stateServer = "", statePort = 0 } [] 1 ha c+ 2 -> do+ liftIO $ putStrLn "************Got success...."+ -- liftIO $ logInfo l "Got success stenza...."+ -- liftIO $ hClose ha+ -- ha' <- liftIO $ liftIO $ connectTo getHost (PortNumber $ fromInteger getPort)+ -- liftIO $ hSetBuffering ha' NoBuffering+ liftIO $ hPutStr ha $ encodeString "<?xml version='1.0'?><stream:stream to='" ++ getHost ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams'" ++ " version='1.0'>"+ liftIO $ hFlush ha+ -- liftIO $ logInfo l "Star to receive data on new handler after success login..."+ loop State { parsingContext = Authenticated, stateServer = "", statePort = 0 } [] 0 ha c+-- Check if counter is one to forward it to related function.+-- Should replace "reverse ((EventEndElement n):es)" with es+loop s ((EventEndElement n):es) 1 ha c =+ do+ liftIO $ processAuthed' (DL.reverse es)+ liftIO $ callEvent $ DL.reverse ((EventEndElement n):es)+ loop s [] 1 ha c++-- Normal condition, buffer the event to events list.+loop s es c ha ch = do+ h <- EL.head+ let c' = counter c h+ liftIO $ putStrLn $ show c'++ "\t" ++show h -- for test+ s' <- liftIO $ processEvent s h+ case h of+ Just e -> loop s' ((toList h) ++ es) c' ha ch+ Nothing -> loop s' es c' ha ch+-- 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++processEvent :: State -> Maybe Event -> IO State+processEvent (State {parsingContext = PreDocument}) me = processDoc me+processEvent (State {parsingContext = Authenticating}) me = processAuthing me+processEvent (State {parsingContext = Challenge}) me = do return (State {parsingContext = Challenge})+processEvent (State {parsingContext = Authenticated}) me = processAuthed me+processEvent (State {parsingContext = Disconnected}) me = processDis me++processDoc :: Maybe Event -> IO State+processDoc (Just EventBeginDocument) =+ do return State { stateServer = "", statePort = 0, parsingContext = Authenticating }+processDoc _ = do return State { stateServer = "", statePort = 0, parsingContext = PreDocument }++processAuthing :: Maybe Event -> IO State+processAuthing (Just (EventBeginElement name attribs))+ | nameLocalName name == DTL.pack "stream"+ && namePrefix name == Just (DTL.pack "stream") =+ -- TODO: Save ID and verify server?+ do return State { stateServer = "", statePort = 0, parsingContext = Authenticating }+ | otherwise = do return State { stateServer = "", statePort = 0, parsingContext = Authenticating }+processAuthing _ = do return State { stateServer = "", statePort = 0, parsingContext = Authenticating }++processChall :: Handle -> [Event] -> IO Int+processChall ha ((EventBeginElement name att):es)+ | nameLocalName name == DTL.pack "challenge" = do+ d <- eventsToDoc ((EventBeginElement name att):es)+ let [n] = elementNodes $ documentRoot d+ let [ContentText t] = isContent n+ let s = CBBS.decode $ show t+ let s' = replyToChallenge1 s getHost getUsername getPass+ "mZqOU2zqYTQbX/FcovCKKOE7Np7Cw/kvo42wrTFdqMs=" -- TODO: Make random+ case s' of+ (Left s'') -> do+ putStrLn "=== RESPONSE ==="+ putStrLn (filter (/= '\n') s'')+ putStrLn "=== END RESPONSE ===\n"+ putStrLn "=== ENCODED RESPONSE ==="+ hPutStr ha $ encodeString $ "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>" +++ (filter (/= '\n') (CBBS.encode s'')) ++ "</response>"+ putStrLn "=== END ENCODED RESPONSE ==="+ (Right r) -> do+ putStrLn $ show r+ return 1+ | nameLocalName name == DTL.pack "success" = do+ return 2+-- processChall _ = return State { stateServer = "", statePort = 0, parsingContext = Challenge }+++processAuthed' :: [Event] -> IO ()+processAuthed' ((EventBeginElement name att):mes)+ | nameLocalName name == DTL.pack "iq" = do+ return ()+ | nameLocalName name == DTL.pack "presence" = do+ return ()+ | otherwise = do+ putStrLn ">>>Got an stenza which is not iq....<<<"+ do return ()++processAuthed :: Maybe Event -> IO State+processAuthed _ = do return State { stateServer = "", statePort = 0, parsingContext = Authenticated }++processDis :: Maybe Event -> IO State+processDis me =+ do return State { stateServer = "", statePort = 0, parsingContext = Disconnected }++featureHandler :: Handle -> [Event] -> IO State+featureHandler ha (e:es) = do+ let ( e' :es') = es+ putStrLn "=================================================================="+ putStrLn "=================================================================="+ f <- getFeatures' (e:es')+ putStrLn "=================================================================="+ putStrLn "=================================================================="+ let fs = getFeatures featuresDefault es+ case authenticating fs of+ True -> do+ hPutStr ha $ encodeString $ getAuth+ return State {stateServer = "", statePort = 0, parsingContext = Challenge }+ False -> return State {stateServer = "", statePort = 0, parsingContext = Disconnected}+++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] }+++++-- See RFC 2888: [...] and RFC 2831: Digest SASL Mechanism for details.++-- data DigestRealm = Realm String++-- data DigestNonce = Nonce String++-- data DigestQop = Auth | AuthInit | AuthConf -- TODO: Token++-- data DigestAlgorithm = MD5Sess++-- data DigestChallenge = DigestChallenge { dcRealm :: DigestRealm+-- , dcNonce :: DigestNonce+-- , dcQop :: DigestQop+-- , dcAlgorithm :: DigestAlgorithm}++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.++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 (realm, nonce, qop, charset, algorithm) of+ (Just realm', 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+ + -- Verify that the realm is the same as the Jabber host.+ in 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+++-- Below is code that was used to test the SASL functionality.++-- main = withSocketsDo $ do+-- ha <- connectTo "test.pontarius.org" (PortNumber $ fromInteger 5222)+-- hSetBuffering ha NoBuffering+-- hPutStr ha $ encodeString "<?xml version='1.0'?><stream:stream to='jabber." +++-- "org' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/strea" +++-- "ms' version='1.0'>"+-- hFlush ha+-- readWrite ha++-- readWrite h = do+-- putStr "Command: "+-- command <- getCommand ""+-- case command of+-- "" -> return ()+-- _ -> do putStrLn $ "Sending: \"" ++ (command) ++ "\"."+-- hPutStr h $ command -- encodeString (command)+-- hFlush h+-- True <- hWaitForInput h (-1)+-- temp <- DBy.hGetNonBlocking h 1024+-- DBy.putStrLn temp+-- readWrite h+-- where+-- getCommand :: String -> IO String+-- getCommand l = do+-- command <- getLine+-- case command of+-- "." -> return l+-- _ -> getCommand $ case l of+-- [] -> command+-- _ -> l ++ "\n" ++ command++-- challenge1 :: String -> IO ()+-- challenge1 s = do+-- let s' = CBBS.decode s+-- putStrLn $ "Got challenge: " ++ s'+-- let s'' = replyToChallenge1 s' "test.pontarius.org" "sprint6" "<pw>"+-- "mZqOU2zqYTQbX/FcovCKKOE7Np7Cw/kvo42wrTFdqMs=" -- TODO: Make random+-- case s'' of+-- (Left s''') -> do+-- putStrLn "=== RESPONSE ==="+-- putStrLn (filter (/= '\n') s''')+-- putStrLn "=== END RESPONSE ===\n"+-- putStrLn "=== ENCODED RESPONSE ==="+-- putStrLn $ "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>" +++-- (filter (/= '\n') (CBBS.encode s''')) ++ "</response>"+-- putStrLn "=== END ENCODED RESPONSE ==="+-- (Right e) -> do+-- putStrLn $ show e+++++++++-- ID Generatation+-- 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)++parseIQ :: Element -> HXMPPEvent+parseIQ e | typeAttr == "get" = let (Just payloadMust) = payload+ in HEIQGet (idAttr, fromAttr, toAttr, payloadMust)+ | typeAttr == "set" = let (Just idMust) = idAttr+ (Just payloadMust) = payload+ in HEIQSet (idMust, fromAttr, toAttr, payloadMust)+ | typeAttr == "result" = let (Just idMust) = idAttr+ in HEIQResult (idMust, fromAttr, toAttr, payload)+ where+ payload = case null (elementChildren e) of+ True -> Nothing+ False -> Just $ head $ elementChildren e+ typeAttr = show (getAttribute e typeName)+ typeName = Name { nameLocalName = DTL.pack "type"+ , nameNamespace = Nothing+ , namePrefix = Nothing }+ fromAttr = case getAttribute e fromName of+ Nothing -> Nothing+ Just a -> Just (stringToJID (show (attributeContent a)))+ fromName = Name { nameLocalName = DTL.pack "from"+ , nameNamespace = Nothing+ , namePrefix = Nothing }+ toAttr = case getAttribute e toName of+ Nothing -> Nothing+ Just a -> Just (stringToJID (show (attributeContent a)))+ toName = Name { nameLocalName = DTL.pack "to"+ , nameNamespace = Nothing+ , namePrefix = Nothing }+ idAttr = case getAttribute e idName of+ Nothing -> Nothing+ Just a -> Just (SID (show (attributeContent a)))+ idName = Name { nameLocalName = DTL.pack "id"+ , nameNamespace = Nothing+ , namePrefix = Nothing }++parsePresence :: Element -> HXMPPEvent+parsePresence e = HEPresence (idAttr, fromAttr, toAttr, typeAttr, children)+ where+ children = elementChildren e+ typeAttr = presence $ show (getAttribute e typeName)+ typeName = Name { nameLocalName = DTL.pack "type"+ , nameNamespace = Nothing+ , namePrefix = Nothing }+ fromAttr = case getAttribute e fromName of+ Nothing -> Nothing+ Just a -> Just (stringToJID (show (attributeContent a)))+ fromName = Name { nameLocalName = DTL.pack "from"+ , nameNamespace = Nothing+ , namePrefix = Nothing }+ toAttr = case getAttribute e toName of+ Nothing -> Nothing+ Just a -> Just (stringToJID (show (attributeContent a)))+ toName = Name { nameLocalName = DTL.pack "to"+ , nameNamespace = Nothing+ , namePrefix = Nothing }+ idAttr = case getAttribute e idName of+ Nothing -> Nothing+ Just a -> Just (SID (show (attributeContent a)))+ idName = Name { nameLocalName = DTL.pack "id"+ , nameNamespace = Nothing+ , namePrefix = Nothing }++presence "available" = Available+presence "away" = Away+presence "chat" = Chat+presence "dnd" = DoNotDisturb+presence "xa" = ExtendedAway+presence "unavailable" = Unavailable++presence_ Available = "available"+presence_ Away = "away"+presence_ Chat = "chat"+presence_ DoNotDisturb = "dnd"+presence_ ExtendedAway = "xa"+presence_ Unavailable = "unavailable"++getAttribute :: Element -> Name -> Maybe Attribute+getAttribute e n = DL.find (\a -> n == getName a) attribs -- Equals ignore prefixes+ where+ attribs = elementAttributes e++clientEventToXML :: ClientEvent -> String+clientEventToXML (CEPresence (presenceType, Nothing)) =+ "<presence><priority>5</priority><show>" ++ (presence_ presenceType) ++ "</show></presence>"+clientEventToXML (CEPresence (presenceType, Just (PS status))) =+ "<presence><priority>5</priority><show>" ++ (presence_ presenceType) ++ "</show><status>" ++ status ++ "</status></presence>"+clientEventToXML (CEIQGet (s, j, e)) = "<iq" ++ (show e) ++ "</iq>"+ where+ s' = case s of+ Nothing -> ""+ Just i -> " id=\"" ++ (show i) ++ "\">"+ j' = case j of+ Nothing -> ""+ Just t -> " to=\"" ++ (jidToString t) ++ "\">"+clientEventToXML (CEIQSet (s, j, e)) = "<iq" ++ (show e) ++ "</iq>" -- Same as above+ where+ s' = case s of+ Nothing -> ""+ Just i -> " id=\"" ++ (show i) ++ "\">"+ j' = case j of+ Nothing -> ""+ Just t -> " to=\"" ++ (jidToString t) ++ "\">"++-- data ClientEvent = CEPresence (PresenceType, Maybe PresenceStatus) |+-- -- CESubscription (Maybe StanzaID, JID, SubscribeType) |+-- CEIQGet (Maybe StanzaID, Maybe JID, Element) |+-- CEIQSet (Maybe StanzaID, Maybe JID, Element) |+-- CEIQResult (Maybe StanzaID, JID, Maybe Element) |+-- CEIQError (Maybe StanzaID, JID, Element, Maybe Element,+-- StanzaErrorType, StanzaErrorCondition) |+-- CEDisconnect deriving (Eq, Show)
+ HXMPPTest.hs view
@@ -0,0 +1,17 @@+module HXMPPTest where++import Control.Concurrent.Chan (Chan, readChan, writeChan)+import HXMPP++main :: IO ()+main =+ do (cc, ch) <- connect "host" 5222+ (Just "user", "server", Just "resource") "password"+ writeChan cc $ presenceEvent Nothing DoNotDisturb (presenceStatus "status")+ loop ch++loop :: Chan HXMPPEvent -> IO ()+loop c =+ do e <- readChan c+ putStrLn $ show e+ loop c
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright © 2011, Jon Kristensen++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++ * Neither the name of Pontarius, HXMPP nor the names of its contributors may+ be used to endorse or promote products derived from this software without+ specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY DIRECT,+INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY+OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,+EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,23 @@+HXMPP aims to be an easy-to-use XMPP library for Haskell. We have just+released an initial prototyped version with the following features:++ * DIGEST-MD5 SASL Authentication+ * Concurrent and Event-based API for XMPP Client Developers+ * Support for Info/Query and Presence Stanzas+ * Interoperable XML Parsing (Using enumerator, xml-enumerator and xml-types)++Please note that we are not recommending anyone to use HXMPP 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 HXMPP anyway, feel free to+contact the Pontarius project and we will try to help you get started.++We are currently working on cleaning up the code, securing the client-to-server+stream using TLS 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 2, on the 23rd of March.++Look at the Pontarius web site <http://www.pontarius.org/>, the HXMPP web page+<http://www.pontarius.org/sub-projects/hxmpp/> and the HXMPP Hackage page+<http://hackage.haskell.org/package/HXMPP/> for more information.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain