diff --git a/HXMPP.cabal b/HXMPP.cabal new file mode 100644 --- /dev/null +++ b/HXMPP.cabal @@ -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: diff --git a/HXMPP.hs b/HXMPP.hs new file mode 100644 --- /dev/null +++ b/HXMPP.hs @@ -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 +-- . 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 "" + 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 "hxmpp" + threadDelay 2000000 + hPutStr ha $ encodeString "5" + 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 = "" + +-- --------------------------------------------------------------------------- +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 "" +-- 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 "" + 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 $ "" ++ + (filter (/= '\n') (CBBS.encode s'')) ++ "" + 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 "" +-- 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" "" +-- "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 $ "" ++ +-- (filter (/= '\n') (CBBS.encode s''')) ++ "" +-- 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)) = + "5" ++ (presence_ presenceType) ++ "" +clientEventToXML (CEPresence (presenceType, Just (PS status))) = + "5" ++ (presence_ presenceType) ++ "" ++ status ++ "" +clientEventToXML (CEIQGet (s, j, e)) = "" + 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)) = "" -- 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) diff --git a/HXMPPTest.hs b/HXMPPTest.hs new file mode 100644 --- /dev/null +++ b/HXMPPTest.hs @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY +OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, +EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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 , the HXMPP web page + and the HXMPP Hackage page + for more information. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain