HXMPP-0.0.1.0: HXMPP.hs
-- | 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)