-- | 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)