pontarius-xmpp-0.0.3.0: Network/XMPP/Session.hs
-- | Module: $Header$
-- Description: XMPP client session management module
-- Copyright: Copyright © 2010-2011 Jon Kristensen
-- License: BSD-3
--
-- Maintainer: info@pontarius.org
-- Stability: unstable
-- Portability: portable
--
-- This module will be documented soon.
-- TODO: Send white-space characters with regular intervals to keep the
-- connection alive.
-- TODO: Add namespace support for stream/features?
-- TODO: Add support for `ver optional' support for features?
-- TODO: Presence priority?
-- TODO: Stop the logger
-- TODO: Catch errors
module Network.XMPP.Session ( XMPPInEvent (..)
, XMPPOutEvent (..)
, createSession ) where
import Network.XMPP.JID
import Network.XMPP.SASL
import Network.XMPP.Stanza
import Network.XMPP.Utilities
import Codec.Binary.UTF8.String
import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
import Control.Concurrent (forkIO, threadDelay)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Data.Enumerator (($$), Iteratee, continue, joinI,
run_, yield)
import Data.Enumerator.Binary (enumHandle, enumFile)
import Data.Maybe
import Data.String
import Data.XML.Types
import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput)
import Network
import Network.TLS
import Network.TLS.Cipher
import System.IO (BufferMode, BufferMode(NoBuffering))
import System.Log.HLogger
import System.Log.SimpleHLogger
import Text.XML.Enumerator.Parse (parseBytes, decodeEntities)
import Text.XML.Enumerator.Document (fromEvents)
import qualified Codec.Binary.Base64.String as CBBS
import qualified Data.ByteString as DB
import qualified Data.ByteString.Lazy as DBL (ByteString, append, pack, fromChunks, toChunks, null)
import qualified Data.ByteString.Lazy.Char8 as DBLC (append, pack, unpack)
import qualified Data.Enumerator as E
import qualified Data.Enumerator.List as EL
import qualified Data.List as DL
import qualified Data.Text as DT
import qualified Data.Text.Lazy as DTL
type Server = String
type Port = Integer
type UserName = String
type Password = String
type Resource = String
data XMPPInEvent = XIEConnectionSucceeded |
XIEConnectionFailed |
XIEAuthenticationSucceeded |
XIEAuthenticationFailed |
XIEMessage Message |
XIEPresence Presence |
XIEIQ IQ |
-- XIEIQJingle | -- Added for Jingle sessions
-- XIEIQXTLS | -- Added for XTLS connection
XIEDisconnect deriving (Eq, Show)
data XMPPOutEvent = XOEConnect Server Port |
XOEAuthenticate UserName Password Resource |
XOEMessage Message |
XOEPresence Presence |
XOEIQ IQ |
-- XOEIQJingle | -- Added for Jingle sessions
-- XOEIQXTLS | -- Added for XTLS connection
XOEDisconnect deriving (Eq, Show)
data SecurityEvent = TLSSucceeded TLSCtx | TLSFailed
instance Show SecurityEvent where
show (TLSSucceeded _) = "TLSSucceeded Ctx"
show TLSFailed = "TLSFailed"
data ConnectionState = Disconnected |
ConnectedNotTLSSecured |
ConnectedTLSSecured TLSCtx
instance Eq ConnectionState where
(==) Disconnected Disconnected = True
(==) ConnectedNotTLSSecured ConnectedNotTLSSecured = True
(==) (ConnectedTLSSecured _) (ConnectedTLSSecured _) = True
(==) _ _ = False
data AuthenticationState = AuthNotRequested |
AuthRequested |
Challenge1Processed |
Authenticated deriving (Eq)
data State = State { stateConnectionState :: ConnectionState
, stateAuthenticationState :: AuthenticationState
, stateHandle :: Maybe Handle
, stateServer :: Maybe (Server, Port)
, stateUserName :: Maybe String
, statePassword :: Maybe String
, stateResource :: Maybe String
, stateStreamID :: Maybe String }
defaultState = State { stateConnectionState = Disconnected
, stateAuthenticationState = AuthNotRequested
, stateHandle = Nothing
, stateServer = Nothing
, stateUserName = Nothing
, statePassword = Nothing
, stateResource = Nothing
, stateStreamID = Nothing }
-- An XMLEvent is a high-level XMPP event generated by our XML parsing code.
data XMLEvent = XEBeginStream Stream | XEFeatures Features |
XEChallenge Challenge | XESuccess Success |
XEEndStream | XEIQ IQ | XEPresence Presence |
XEMessage Message | XEOther String deriving (Show)
-- Represents the top-level "<stream>" element.
data Stream = Stream { streamNamespace :: StreamNamespace
, streamID :: String
, streamVersion :: Float } deriving (Show)
-- TODO: Do not make this assumption, but parse the element instead.
defaultStream id = Stream { streamNamespace = Client
, streamID = id
, streamVersion = 1.0 }
-- The "<stream:features>" element.
data Features = Features { featuresStartTLS :: Bool
, featuresMechanisms :: [FeaturesMechanism]
, featuresCompressionMethods :: [CompressionMethod] } deriving (Show)
-- TODO: Do not make this assumption, but parse the element instead.
featuresDefault = Features { featuresStartTLS = True,
featuresMechanisms = [DigestMD5],
featuresCompressionMethods = [] }
-- TODO: Necessary?
data StreamNamespace = Client | Server deriving (Show)
-- Authentication mechanisms. We only support DigestMD5 at this point.
data FeaturesMechanism = DigestMD5 | CramMD5 | Login | Plain | UnknownMechanism deriving (Show)
data UnknownMechanism = UM String deriving (Show)
data CompressionMethod = Zlib deriving (Show)
-- Containers for information from SASL challenges and successes.
data Challenge = Chal String deriving (Show)
data Success = Succ String deriving (Show)
data InternalEvent = IEX XMLEvent |
IEO XMPPOutEvent |
IES SecurityEvent deriving (Show)
-- | Creates a Pontarius XMPP session by setting up internal processes and state
-- and creates the two (in and out) event channels that the XMPP client uses
-- for communicating with Pontarius XMPP.
createSession :: IO (Chan XMPPInEvent, Chan XMPPOutEvent)
createSession = do
logger <- simpleLogger "PontariusXMPP"
loggerLog logger (Just ("Session", "createSession")) Info "Pontarius XMPP has started"
-- Create client "in" and "out" channels (naming from the perspective of the
-- XMPP client) as well as the internal event channel used by the state loop
inChan <- newChan
outChan <- newChan
internalChan <- newChan
-- Start to listen to client "out" events (client actions)
forkIO $ clientListener outChan internalChan logger
-- Start the state loop, the main loop of Pontarius XMPP
forkIO $ stateLoop defaultState internalChan inChan logger
return (inChan, outChan)
-- Receives events from the XMPP client and forwards them to the state loop by
-- using the internal event channel.
clientListener :: Chan XMPPOutEvent -> Chan InternalEvent -> Logger -> IO ()
clientListener c c_ l =
do event <- readChan c
loggerLog l (Just ("Session", "clientListener")) Debug $ "clientListener: Forwarding received client event: " ++ show (event)
writeChan c_ (IEO event)
clientListener c c_ l
-- Processes internal events to possibly perform actions and update the session
-- state. Note that the InternalEvent type wraps the external client events.
stateLoop :: State -> Chan InternalEvent -> Chan XMPPInEvent -> Logger -> IO ()
stateLoop s c c_ l =
do event <- readChan c
-- logDebug l $ "stateLoop: Received event: " ++ (show event)
-- TODO: Debug with state?
s' <- processEvent event
stateLoop s' c c_ l
where
connectionState = stateConnectionState s
authenticationState = stateAuthenticationState s
handle = stateHandle s
server = stateServer s
userName = stateUserName s
password = statePassword s
resource = stateResource s
streamID = stateStreamID s
Just (serverHost, serverPort) = stateServer s
tlsCtx = let ConnectedTLSSecured x = connectionState in x
-- let xml = clientOutEventToXML clientEvent
-- logDebug l $ "processEvent: Sending XML: " ++ xml
-- sendData (fromJust tlsCtx) $ DBLC.pack $ encodeString $ xml
processEvent (IEO clientOutEvent) = do
loggerLog l (Just ("Session", "processEvent")) Debug $ "Processing client out event " ++ (show clientOutEvent)
case clientOutEvent of
XOEConnect serverHost_ serverPort_ -> do
handle <- connectTo serverHost_ (PortNumber $ fromInteger serverPort_)
hSetBuffering handle NoBuffering
hPutStr handle $ encodeString $
"<?xml version='1.0'?><stream:stream to='" ++ serverHost_ ++
"' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.or" ++
"g/streams' version='1.0'>"
hFlush handle
-- Start XML enumerator, which will read from the handle to generate the
-- relevant internal events
forkIO $ xmlEnumerator c handle serverHost_ l
return s { stateConnectionState = ConnectedNotTLSSecured
, stateHandle = Just handle
, stateServer = Just (serverHost_, serverPort_) }
-- TODO: Function to verify certificate?
XOEAuthenticate userName_ password_ resource_ -> do
sendData tlsCtx $ DBLC.pack $ encodeString
"<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='DIGEST-MD5'/>"
return s { stateAuthenticationState = AuthRequested
, stateUserName = Just userName_
, statePassword = Just password_
, stateResource = Just resource_ }
XOEPresence presence -> do
presence' <- case stanzaID $ presenceStanza presence of
Nothing -> do
id <- getID
return $ presence { presenceStanza = (presenceStanza presence) { stanzaID = Just (SID id) } }
_ -> return presence
let xml = presenceToXML presence'
loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Will send presence XML: " ++ xml
sendData tlsCtx $ DBLC.pack $ encodeString $ xml
return s
XOEMessage message -> do
message' <- case stanzaID $ messageStanza message of
Nothing -> do
id <- getID
return $ message { messageStanza = (messageStanza message) { stanzaID = Just (SID id) } }
_ -> return message
let xml = messageToXML message'
loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Will send message XML: " ++ xml
sendData tlsCtx $ DBLC.pack $ encodeString $ xml
return s
XOEIQ iq -> do
iq' <- case stanzaID $ iqStanza iq of
Nothing -> do
id <- getID
return $ case iq of
IQGet {} -> do
iq { iqGetStanza = (iqStanza iq) { stanzaID = Just (SID id) } }
IQSet {} -> do
iq { iqSetStanza = (iqStanza iq) { stanzaID = Just (SID id) } }
IQResult {} -> do
iq { iqResultStanza = (iqStanza iq) { stanzaID = Just (SID id) } }
_ -> return iq
let xml = iqToXML iq'
loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Will send IQ XML: " ++ xml
sendData tlsCtx $ DBLC.pack $ encodeString $ xml
return s
XOEDisconnect -> do
-- TODO: Close stream
return s
-- TODO: processEvent (IES TLSFailed) =
processEvent (IES (TLSSucceeded receivedTLSCtx)) =
return (s { stateConnectionState = ConnectedTLSSecured receivedTLSCtx })
-- A <stream:stream> element has begun
-- TODO: Parse the XEStreamBegin object
processEvent (IEX (XEBeginStream _)) = do
loggerLog l (Just ("Session", "processEvent")) Debug "processEvent: A new stream has been opened"
return s
-- We have received <features> on an insecure stream
-- TODO: Parse the XEFeatures object
processEvent (IEX (XEFeatures _))
| connectionState == ConnectedNotTLSSecured = do
loggerLog l (Just ("Session", "processEvent")) Debug $
"processEvent: Received features ([...]) on insecure stream; req" ++
"uesting \"starttls\""
hPutStr (fromJust handle) $
"<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>"
hFlush (fromJust handle)
return s
-- We have received <features> on a secure and non-authenticated stream
processEvent (IEX (XEFeatures _))
| connectionState == ConnectedTLSSecured tlsCtx &&
authenticationState /= Authenticated = do
loggerLog l (Just ("Session", "processEvent")) Debug $
"processEvent: Received features ([...]) on an unauthenticated" ++
" secure stream"
writeChan c_ $ XIEConnectionSucceeded
return s
-- We have received <features> on an authenticated secure stream; we are
-- now ready to start processing client events
processEvent (IEX (XEFeatures _))
| connectionState == ConnectedTLSSecured tlsCtx = do
loggerLog l (Just ("Session", "processEvent")) Debug $
"processEvent: Received features ([...]) on an authenticated sec" ++
"ure stream"
loggerLog l (Just ("Session", "processEvent")) Info $ "processEvent: User has successfully logged in"
case resource of
Nothing -> do
sendData tlsCtx $ DBLC.pack $ encodeString
"<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:param" ++
"s:xml:ns:xmpp-bind\"></bind></iq>"
return ()
_ -> do
loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Setting resource: " ++
(fromJust resource)
sendData tlsCtx $ DBLC.pack $ encodeString
"<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:param" ++
"s:xml:ns:xmpp-bind\"><resource>" ++ fromJust resource ++
"</resource></bind></iq>"
return ()
r <- getID
sendData tlsCtx $ DBLC.pack $ encodeString $
"<iq type=\"set\" id=\"" ++ r ++
"\"><session xmlns=\"urn:ietf:params:xml:ns:xmpp-session\"/>" ++
"</iq>"
writeChan c_ $ XIEAuthenticationSucceeded
return (s { stateAuthenticationState = Authenticated })
-- We have received a SASL challenge on a secure stream
processEvent (IEX (XEChallenge (Chal challenge)))
| connectionState == ConnectedTLSSecured tlsCtx = do
let challenge' = CBBS.decode challenge
case authenticationState of
AuthRequested -> do
-- This is the first challenge - we need to calculate the reply
loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Received initial challenge: " ++
challenge ++ " (or " ++ challenge' ++ ")"
random <- getID -- TODO: Length and content.
case replyToChallenge1 challenge' serverHost (fromJust userName)
(fromJust password) random of
Left reply -> do
let reply' = (filter (/= '\n') (CBBS.encode reply))
loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Sending challenge response: " ++
reply'
sendData tlsCtx $ DBLC.pack $ encodeString $
"<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>" ++
reply' ++ "</response>"
return (s { stateAuthenticationState = Challenge1Processed } )
Right error -> do
putStrLn $ show error
return s
Challenge1Processed -> do
-- This is not the first challenge; [...]
-- TODO: Can we assume "rspauth"?
loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Received non-initial challenge: " ++
challenge ++ " (or " ++ challenge' ++ ")"
liftIO $ sendData tlsCtx $ DBLC.pack $ encodeString $
"<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/>"
return s
-- We have received a SASL "success" message over a secured connection
-- TODO: Parse the success message?
-- TODO: <?xml version='1.0'?>?
processEvent (IEX (XESuccess (Succ _)))
| connectionState == ConnectedTLSSecured tlsCtx = do
loggerLog l (Just ("Session", "processEvent")) Debug $
"processEvent: Received authentication success: [...]; restartin" ++
"g stream" -- TODO
sendData tlsCtx $ DBLC.pack $
encodeString "<?xml version='1.0'?><stream:stream to='" ++
serverHost ++
"' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++
"streams' version='1.0'>"
return s { stateAuthenticationState = Authenticated }
-- Ignore id="bind_1" and session IQ result, otherwise create client event
processEvent (IEX (XEIQ iqEvent))
| authenticationState == Authenticated = do
case shouldIgnoreIQ iqEvent of
True ->
return s
False -> do
loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Got IQ for client: " ++
(show iqEvent)
writeChan c_ $ XIEIQ iqEvent
return s
processEvent (IEX (XEPresence presenceEvent))
| authenticationState == Authenticated = do
loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Got presence for client: " ++
(show presenceEvent)
writeChan c_ $ XIEPresence presenceEvent
return s
processEvent (IEX (XEMessage messageEvent)) = do
loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Got message for client: " ++
(show messageEvent)
writeChan c_ $ XIEMessage messageEvent
return s
-- We received an XML element that we didn't parse
processEvent (IEX xmlEvent) = do
loggerLog l (Just ("Session", "processEvent")) Warning $ "processEvent: XML event slipped through: " ++
(show xmlEvent)
return s
shouldIgnoreIQ :: IQ -> Bool
shouldIgnoreIQ i = case iqPayload i of
Nothing -> False
Just e -> case nameNamespace $ elementName e of
Just x | x == DT.pack "urn:ietf:params:xml:ns:xmpp-bind" -> True
Just x | x == DT.pack "urn:ietf:params:xml:ns:xmpp-session" -> True
Just _ -> False
Nothing -> False
parseIQ :: Element -> IQ
parseIQ e | typeAttr == "get" = let (Just payloadMust) = payload
in iqGet idAttr fromAttr toAttr Nothing
payloadMust
| typeAttr == "set" = let (Just payloadMust) = payload
in iqSet idAttr fromAttr toAttr Nothing
payloadMust
| typeAttr == "result" = iqResult idAttr fromAttr toAttr Nothing
payload
where
-- TODO: Many duplicate functions from parsePresence.
payload :: Maybe Element
payload = case null (elementChildren e) of
True -> Nothing
False -> Just $ head $ elementChildren e
typeAttr :: String
typeAttr = case attributeText typeName e of
-- Nothing -> Nothing
Just a -> DT.unpack a
fromAttr :: Maybe JID
fromAttr = case attributeText fromName e of
Nothing -> Nothing
Just a -> stringToJID $ DT.unpack a
toAttr :: Maybe JID
toAttr = case attributeText toName e of
Nothing -> Nothing
Just a -> stringToJID $ DT.unpack a
idAttr :: Maybe StanzaID
idAttr = case attributeText idName e of
Nothing -> Nothing
Just a -> Just (SID (DT.unpack a))
typeName :: Name
typeName = fromString "type"
fromName :: Name
fromName = fromString "from"
toName :: Name
toName = fromString "to"
idName :: Name
idName = fromString "id"
-- TODO: Parse xml:lang
parsePresence :: Element -> Presence
parsePresence e = presence idAttr fromAttr toAttr Nothing typeAttr (elementChildren e)
where
-- TODO: Many duplicate functions from parseIQ.
typeAttr :: PresenceType
typeAttr = case attributeText typeName e of
Just t -> stringToPresenceType $ DT.unpack t
Nothing -> Available
fromAttr :: Maybe JID
fromAttr = case attributeText fromName e of
Nothing -> Nothing
Just a -> stringToJID $ DT.unpack a
toAttr :: Maybe JID
toAttr = case attributeText toName e of
Nothing -> Nothing
Just a -> stringToJID $ DT.unpack a
idAttr :: Maybe StanzaID
idAttr = case attributeText idName e of
Nothing -> Nothing
Just a -> Just (SID (DT.unpack a))
fromName :: Name
fromName = fromString "from"
typeName :: Name
typeName = fromString "type"
toName :: Name
toName = fromString "to"
idName :: Name
idName = fromString "id"
parseMessage :: Element -> Message
parseMessage e = message idAttr fromAttr toAttr Nothing typeAttr (elementChildren e)
where
-- TODO: Many duplicate functions from parseIQ.
typeAttr :: MessageType
typeAttr = case attributeText typeName e of
Just t -> stringToMessageType $ DT.unpack t
Nothing -> Normal
fromAttr :: Maybe JID
fromAttr = case attributeText fromName e of
Nothing -> Nothing
Just a -> stringToJID $ DT.unpack a
toAttr :: Maybe JID
toAttr = case attributeText toName e of
Nothing -> Nothing
Just a -> stringToJID $ DT.unpack a
idAttr :: Maybe StanzaID
idAttr = case attributeText idName e of
Nothing -> Nothing
Just a -> Just (SID (DT.unpack a))
fromName :: Name
fromName = fromString "from"
typeName :: Name
typeName = fromString "type"
toName :: Name
toName = fromString "to"
idName :: Name
idName = fromString "id"
-- stringToPresenceType "available" = Available
-- stringToPresenceType "away" = Away
-- stringToPresenceType "chat" = Chat
-- stringToPresenceType "dnd" = DoNotDisturb
-- stringToPresenceType "xa" = ExtendedAway
stringToPresenceType "probe" = Probe
stringToPresenceType "error" = PresenceError
stringToPresenceType "unavailable" = Unavailable
stringToPresenceType "subscribe" = Subscribe
stringToPresenceType "subscribed" = Subscribed
stringToPresenceType "unsubscribe" = Unsubscribe
stringToPresenceType "unsubscribed" = Unsubscribed
-- presenceTypeToString Available = "available"
-- presenceTypeToString Away = "away"
-- presenceTypeToString Chat = "chat"
-- presenceTypeToString DoNotDisturb = "dnd"
-- presenceTypeToString ExtendedAway = "xa"
presenceTypeToString Unavailable = "unavailable"
presenceTypeToString Probe = "probe"
presenceTypeToString PresenceError = "error"
presenceTypeToString Subscribe = "subscribe"
presenceTypeToString Subscribed = "subscribed"
presenceTypeToString Unsubscribe = "unsubscribe"
presenceTypeToString Unsubscribed = "unsubscribed"
stringToMessageType "chat" = Chat
stringToMessageType "error" = MessageError
stringToMessageType "groupchat" = Groupchat
stringToMessageType "headline" = Headline
stringToMessageType "normal" = Normal
stringToMessageType s = OtherMessageType s
messageTypeToString Chat = "chat"
messageTypeToString MessageError = "error"
messageTypeToString Groupchat = "groupchat"
messageTypeToString Headline = "headline"
messageTypeToString Normal = "normal"
messageTypeToString (OtherMessageType s) = s
xmlEnumerator :: Chan InternalEvent -> Handle -> String -> Logger -> IO ()
xmlEnumerator c h s l = do
loggerLog l (Just ("Session", "processEvent")) Debug $ "xmlEnumerator: Starting to read insecure XML"
run_ $ enumHandle 1 h $$ joinI $ parseBytes decodeEntities
$$ xmlReader c [] 0
loggerLog l (Just ("Session", "processEvent")) Debug $ "xmlEnumerator: Unsecure stream ended - performing TLS handshake"
t <- handshake' h s
case t of
Just tlsctx -> do loggerLog l (Just ("Session", "processEvent")) Debug $ "xmlEnumerator: Handshake successful - st" ++
"arting to read secure XML"
writeChan c (IES (TLSSucceeded tlsctx))
run_ $ enumTLS tlsctx $$ joinI $ parseBytes decodeEntities
$$ xmlReader c [] 0
loggerLog l (Just ("Session", "processEvent")) Debug $
"xmlEnumerator: Secure stream ended, exiting"
return ()
Nothing -> loggerLog l (Just ("Session", "processEvent")) Debug $ "xmlEnumerator: TLS handshake failed" -- TODO: Event
return ()
enumTLS :: TLSCtx -> E.Enumerator DB.ByteString IO b
enumTLS c s = loop c s where
loop :: TLSCtx -> E.Step DB.ByteString IO b -> E.Iteratee DB.ByteString IO b
loop c (E.Continue k) =
do d <- recvData c
case DBL.null d of
True -> loop c (E.Continue k)
False -> k (E.Chunks $ DBL.toChunks d) E.>>== loop c
loop _ step = E.returnI step
hPutStr' :: Handle -> String -> IO ()
hPutStr' h s = do
hPutStr h $ encodeString "<?xml version='1.0'?><stream:stream to='" ++
s ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++
"streams' version='1.0'>"
hFlush h
getTLSParams :: TLSParams
getTLSParams = TLSParams { pConnectVersion = TLS10
, pAllowedVersions = [TLS10,TLS11]
, pCiphers = [cipher_AES256_SHA1] -- Check the rest
, pCompressions = [nullCompression]
, pWantClientCert = False
, pCertificates = []
, onCertificatesRecv = \_ -> return True } -- Verify cert chain
handshake' :: Handle -> String -> IO (Maybe TLSCtx)
handshake' h s = do
let t = getTLSParams
r <- makeSRandomGen
case r of
Right sr -> do
putStrLn $ show sr
c <- client t sr h
handshake c
sendData c $ DBLC.pack $ encodeString "<?xml version='1.0'?><stream:stream to='" ++
s ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++
"streams' version='1.0'>"
putStrLn ">>>>TLS data sended<<<<"
return (Just c)
Left ge -> do
putStrLn $ show ge
return Nothing
-- TODO: Add logger
xmlReader :: Chan InternalEvent -> [Event] -> Int ->
Iteratee Event IO (Maybe Event)
xmlReader ch [EventBeginDocument] 0 = xmlReader ch [] 0
-- TODO: Safe to start change level here? We are doing this since the stream can
-- restart.
-- TODO: l < 2?
xmlReader ch [EventBeginElement name attribs] l
| l < 3 && nameLocalName name == DT.pack "stream" &&
namePrefix name == Just (DT.pack "stream") = do
liftIO $ writeChan ch $ IEX $ XEBeginStream $ defaultStream "TODO"
xmlReader ch [] 1
xmlReader ch [EventEndElement name] 1
| namePrefix name == Just (DT.pack "stream") &&
nameLocalName name == DT.pack "stream" = do
liftIO $ writeChan ch $ IEX XEEndStream
return Nothing
-- Check if counter is one to forward it to related function.
-- Should replace "reverse ((EventEndElement n):es)" with es
-- ...
xmlReader ch ((EventEndElement n):es) 1
| nameLocalName n == DT.pack "proceed" = E.yield Nothing (E.Chunks [])
| otherwise = do
-- liftIO $ putStrLn "Got an IEX Event..."
liftIO $ writeChan ch $ IEX (processEventList (DL.reverse ((EventEndElement n):es)))
xmlReader ch [] 1
-- Normal condition, buffer the event to events list.
xmlReader ch es co = do
head <- EL.head
let co' = counter co head
liftIO $ putStrLn $ show co' ++ "\t" ++ show head -- for test
case head of
Just e -> xmlReader ch (e:es) co'
Nothing -> xmlReader ch es co'
-- TODO: Generate real event.
processEventList :: [Event] -> XMLEvent
processEventList e
| namePrefix name == Just (DT.pack "stream") &&
nameLocalName name == DT.pack "features" = XEFeatures featuresDefault
| nameLocalName name == DT.pack "challenge" =
let EventContent (ContentText c) = head es in XEChallenge $ Chal $ DT.unpack c
| nameLocalName name == DT.pack "success" =
let EventContent (ContentText c) = head es in XESuccess $ Succ $ DT.unpack c
| nameLocalName name == DT.pack "iq" = XEIQ $ parseIQ $ eventsToElement e
| nameLocalName name == DT.pack "presence" = XEPresence $ parsePresence $ eventsToElement e
| nameLocalName name == DT.pack "message" = XEMessage $ parseMessage $ eventsToElement e
| otherwise = XEOther $ elementToString $ Just (eventsToElement e)
where
(EventBeginElement name attribs) = head e
es = tail e
eventsToElement :: [Event] -> Element
eventsToElement e = do
documentRoot $ fromJust (run_ $ enum e $$ fromEvents)
where
enum :: [Event] -> E.Enumerator Event Maybe Document
enum e_ (E.Continue k) = k $ E.Chunks e_
enum e_ step = E.returnI step
counter :: Int -> Maybe Event -> Int
counter c (Just (EventBeginElement _ _)) = (c + 1)
counter c (Just (EventEndElement _) ) = (c - 1)
counter c _ = c
presenceToXML :: Presence -> String
presenceToXML p = "<presence" ++ from ++ id' ++ to ++ type' ++ ">" ++
(elementsToString $ presencePayload p) ++ "</presence>"
where
s = presenceStanza p
from :: String
from = case stanzaFrom $ presenceStanza p of
-- TODO: Lower-case
Just s -> " from='" ++ (jidToString s) ++ "'"
Nothing -> ""
id' :: String
id' = case stanzaID s of
Just (SID s) -> " id='" ++ s ++ "'"
Nothing -> ""
to :: String
to = case stanzaTo $ presenceStanza p of
-- TODO: Lower-case
Just s -> " to='" ++ (jidToString s) ++ "'"
Nothing -> ""
type' :: String
type' = case presenceType p of
Available -> ""
t -> " type='" ++ (presenceTypeToString t) ++ "'"
iqToXML :: IQ -> String
iqToXML IQGet { iqGetStanza = s, iqGetPayload = p } =
let type' = " type='get'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString (Just p)) ++ "</iq>"
where
from :: String
from = case stanzaFrom s of
-- TODO: Lower-case
Just s -> " from='" ++ (jidToString s) ++ "'"
Nothing -> ""
id' :: String
id' = case stanzaID s of
Just (SID s) -> " id='" ++ s ++ "'"
Nothing -> ""
to :: String
to = case stanzaTo s of
-- TODO: Lower-case
Just s -> " to='" ++ (jidToString s) ++ "'"
Nothing -> ""
iqToXML IQSet { iqSetStanza = s, iqSetPayload = p } =
let type' = " type='set'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString (Just p)) ++ "</iq>"
where
from :: String
from = case stanzaFrom s of
-- TODO: Lower-case
Just s -> " from='" ++ (jidToString s) ++ "'"
Nothing -> ""
id' :: String
id' = case stanzaID s of
Just (SID s) -> " id='" ++ s ++ "'"
Nothing -> ""
to :: String
to = case stanzaTo s of
-- TODO: Lower-case
Just s -> " to='" ++ (jidToString s) ++ "'"
Nothing -> ""
iqToXML IQResult { iqResultStanza = s, iqResultPayload = p } =
let type' = " type='result'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString p) ++ "</iq>"
where
from :: String
from = case stanzaFrom s of
-- TODO: Lower-case
Just s -> " from='" ++ (jidToString s) ++ "'"
Nothing -> ""
id' :: String
id' = case stanzaID s of
Just (SID s) -> " id='" ++ s ++ "'"
Nothing -> ""
to :: String
to = case stanzaTo s of
-- TODO: Lower-case
Just s -> " to='" ++ (jidToString s) ++ "'"
Nothing -> ""
messageToXML :: Message -> String
messageToXML m = "<message" ++ from ++ id' ++ to ++ type' ++ ">" ++
(elementsToString $ messagePayload m) ++ "</message>"
where
s = messageStanza m
from :: String
from = case stanzaFrom $ messageStanza m of
-- TODO: Lower-case
Just s -> " from='" ++ (jidToString s) ++ "'"
Nothing -> ""
id' :: String
id' = case stanzaID s of
Just (SID s) -> " id='" ++ s ++ "'"
Nothing -> ""
to :: String
to = case stanzaTo $ messageStanza m of
-- TODO: Lower-case
Just s -> " to='" ++ (jidToString s) ++ "'"
Nothing -> ""
type' :: String
type' = case messageType m of
Normal -> ""
t -> " type='" ++ (messageTypeToString t) ++ "'"