{-
Copyright © 2010-2011 Jon Kristensen.
This file is part of Pontarius XMPP.
Pontarius XMPP is free software: you can redistribute it and/or modify it under
the terms of the GNU Lesser General Public License as published by the Free
Software Foundation, either version 3 of the License, or (at your option) any
later version.
Pontarius XMPP is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more
details.
You should have received a copy of the GNU Lesser General Public License along
with Pontarius XMPP. If not, see .
-}
-- | Module: $Header$
-- Description: XMPP client session management module
-- Copyright: Copyright © 2010-2011 Jon Kristensen
-- License: LGPL-3
--
-- Maintainer: info@pontarius.org
-- Stability: unstable
-- Portability: portable
-- I believe we need to use the MultiParamTypeClasses extension to be able to
-- work with arbitrary client states (solving the problem that the ClientState
-- type class is solving). However, I would be happy if someone proved me wrong.
{-# LANGUAGE MultiParamTypeClasses #-}
-- TODO: Better functions and events for stanzas, IncomingIQ, OutgoingIQ, etc. (ClientSession, ClientStanza)
-- TODO: IO function to do everything related to the handle, instead of just connecting.
-- TODO: Enumerate in the same thread? Enumerate one element at the time, non-blocking?
-- | This module provides the functions used by XMPP clients to manage their
-- XMPP sessions.
--
-- Working with Pontarius XMPP is mostly done asynchronously with callbacks;
-- Pontarius XMPP "owns" the XMPP thread and carries the client state with it.
-- A client consists of a list of client handlers to handle XMPP events. This
-- is all set up through a @Session@ object, which a client can create by
-- calling the (blocking) function @createSession@.
--
-- The Pontarius XMPP functions operate in an arbitrary MonadIO monad.
-- Typically, clients will use the IO monad.
--
-- For more information, see the Pontarius XMPP Manual.
module Network.XMPP.Session ( Certificate
, ClientHandler (..)
, ClientState (..)
, ConnectResult (..)
, HostName
, Password
, PortNumber
, Resource
, Session
, TerminationReason
, UserName
, OpenStreamResult (..)
, SecureWithTLSResult (..)
, AuthenticateResult (..)
, sendPresence
, sendIQ
, sendMessage
, connect
, openStream
, secureWithTLS
, authenticate
, createSession ) where
import Network.XMPP.JID
import Network.XMPP.SASL
import Network.XMPP.Stanza
import Network.XMPP.Utilities
import qualified Control.Exception as CE
import qualified Control.Exception.Base as CEB -- ?
import qualified Control.Monad.Error as CME
import qualified Control.Monad.State as CMS
import qualified Network as N
-------------
import Control.Concurrent.MVar
import Codec.Binary.UTF8.String
import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Monad.State hiding (State)
import Data.Enumerator (($$), Iteratee, continue, joinI,
run, 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.TLS
import Network.TLS.Cipher
import System.IO (BufferMode, BufferMode(NoBuffering))
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
-- =============================================================================
-- EXPORTED TYPES AND FUNCTIONS
-- =============================================================================
-- | The @Session@ object is used by clients when interacting with Pontarius
-- XMPP. It holds information needed by Pontarius XMPP; its content is not
-- accessible from the client.
data Session s m = Session { sessionChannel :: Chan (InternalEvent s m) }
-- | A client typically needs one or more @ClientHandler@ objects to interact
-- with Pontarius XMPP. Each client handler may provide four callback
-- functions; the first three callbacks deals with received stanzas, and the
-- last one is used when the session is terminated.
--
-- These stanza functions takes the current client state and an object
-- containing the details of the stanza in question. The boolean returned
-- along with the possibly updated state signals whether or not the message
-- should be blocked to client handlerss further down the stack. For example,
-- an XEP-0030: Service Discovery handler may choose to hide disco\#info
-- requests to handlers above it in the stack.
--
-- The 'sessionTerminated' callback function takes a 'TerminationReason' value
-- along with the state and will be sent to all client handlers.
data MonadIO m => ClientHandler s m =
ClientHandler { messageReceived :: Maybe (Message -> StateT s m Bool)
, presenceReceived :: Maybe (Presence -> StateT s m Bool)
, iqReceived :: Maybe (IQ -> StateT s m Bool)
, sessionTerminated :: Maybe (TerminationReason ->
StateT s m ()) }
-- | Readability type for host name Strings.
type HostName = String -- This is defined in Network as well
-- | Readability type for port number Integers.
type PortNumber = Integer -- We use N(etwork).PortID (PortNumber) internally
-- | Readability type for user name Strings.
type UserName = String
-- | Readability type for password Strings.
type Password = String
-- | Readability type for (JID) resource identifier Strings.
type Resource = String
-- | @TerminationReason@ contains information on why the XMPP session was
-- terminated.
data TerminationReason = WhateverReason -- TODO
type Certificate = String -- TODO
data ConnectResult = ConnectSuccess StreamProperties StreamFeatures (Maybe Resource) |
ConnectOpenStreamFailure |
ConnectSecureWithTLSFailure |
ConnectAuthenticateFailure
data OpenStreamResult = OpenStreamSuccess StreamProperties StreamFeatures |
OpenStreamFailure
data SecureWithTLSResult = SecureWithTLSSuccess StreamProperties StreamFeatures | SecureWithTLSFailure
data AuthenticateResult = AuthenticateSuccess StreamProperties StreamFeatures Resource | AuthenticateFailure
type StreamProperties = Float
type StreamFeatures = String
-- | Creates an XMPP session. Blocks the current thread. The first parameter,
-- @s@, is an arbitrary state that is defined by the client. This is the
-- initial state, and it will be passed to the client (handlers) as XMPP
-- events are emitted. The second parameter is the list of @ClientHandler@s;
-- this is a way to provide a "layered" system of XMPP event handlers. For
-- example, a client may have a dedicated handler to manage messages,
-- implement a spam protection system, etc. Messages are piped through these
-- handlers one by one, and any handler may block the message from being sent
-- to the next handler(s) above in the stack. The third argument is a callback
-- function that will be called when the session has been initialized, and
-- this function should be used by the client to store the Session object in
-- its state.
-- Creates the internal event channel, injects the Pontarius XMPP session object
-- into the ClientState object, runs the "session created" client callback (in
-- the new state context), and stores the updated client state in s''. Finally,
-- we launch the (main) state loop of Pontarius XMPP.
createSession :: (MonadIO m, ClientState s m) => s -> [ClientHandler s m] ->
(CMS.StateT s m ()) -> m ()
createSession s h c = do
threadID <- liftIO $ newEmptyMVar
chan <- liftIO $ newChan
((), clientState) <- runStateT c (putSession s $ session chan)
(result, _) <- runStateT (stateLoop chan)
(defaultState chan threadID h clientState)
case result of
Just (CE.SomeException e) -> do
liftIO $ putStrLn "Got an exception!"
threadID' <- liftIO $ tryTakeMVar threadID
case threadID' of
Nothing -> do
liftIO $ putStrLn "No thread ID to kill"
Just t -> do
liftIO $ putStrLn "Killing thread"
liftIO $ killThread t
CE.throw e
Nothing ->
return ()
where
-- session :: Chan (InternalEvent m s) -> Session m s -- TODO
session c = Session { sessionChannel = c }
defaultState :: (MonadIO m, ClientState s m) => Chan (InternalEvent s m) -> MVar ThreadId ->
[ClientHandler s m] -> s -> State s m
defaultState c t h s = State { stateClientHandlers = h
, stateClientState = s
, stateChannel = c
, stateConnectionState = Disconnected
, stateStreamState = PreStream
, stateTLSState = NoTLS
, stateOpenStreamCallback = Nothing
, stateSecureWithTLSCallback = Nothing
, stateAuthenticateCallback = Nothing
, stateAuthenticationState = NoAuthentication
, stateResource = Nothing
, stateShouldExit = False
, stateThreadID = t
, stateIQCallbacks = [] }
connect :: MonadIO m => Session s m -> HostName -> PortNumber ->
Maybe (Certificate, (Certificate -> Bool)) ->
Maybe (UserName, Password, Maybe Resource) ->
(ConnectResult -> StateT s m ()) -> StateT s m ()
-- data ConnectResult = ConnectSuccess StreamProperties StreamFeatures Resource |
-- ConnectOpenStreamFailure |
-- ConnectTLSSecureStreamFailure |
-- ConnectAuthenticateFailure
-- data OpenStreamResult = OpenStreamSuccess StreamProperties StreamFeatures |
-- OpenStreamFailure
-- data SecureWithTLSResult = SecureWithTLSSuccess StreamProperties StreamFeatures | SecureWithTLSFailure
-- data AuthenticateResult = AuthenticateSuccess Resource | AuthenticateFailure
connect s h p t a c = openStream s h p connect'
where
connect' r = case r of
OpenStreamSuccess _ _ -> case t of -- TODO: Check for TLS support?
Just (certificate, certificateValidator) ->
secureWithTLS s certificate certificateValidator connect''
Nothing -> connect'' (SecureWithTLSSuccess 1.0 "") -- TODO
OpenStreamFailure -> c ConnectOpenStreamFailure
connect'' r = case r of
SecureWithTLSSuccess _ _ -> case a of
Just (userName, password, resource) ->
authenticate s userName password resource connect'''
Nothing -> connect''' (AuthenticateSuccess 1.0 "" "todo") -- TODO
SecureWithTLSFailure -> c ConnectSecureWithTLSFailure
connect''' r = case r of
AuthenticateSuccess streamProperties streamFeatures resource ->
c (ConnectSuccess streamProperties streamFeatures (Just resource))
AuthenticateFailure -> c ConnectAuthenticateFailure
openStream :: MonadIO m => Session s m -> HostName -> PortNumber ->
(OpenStreamResult -> StateT s m ()) -> StateT s m ()
openStream s h p c = CMS.get >>=
(\ state -> lift $ liftIO $ writeChan (sessionChannel s)
(IEC (CEOpenStream state h p c)))
secureWithTLS :: MonadIO m => Session s m -> Certificate ->
(Certificate -> Bool) ->
(SecureWithTLSResult -> StateT s m ()) -> StateT s m ()
secureWithTLS s c a c_ = CMS.get >>=
(\ state -> lift $ liftIO $
writeChan (sessionChannel s)
(IEC (CESecureWithTLS state c a c_)))
-- |
authenticate :: MonadIO m => Session s m -> UserName -> Password ->
Maybe Resource -> (AuthenticateResult -> StateT s m ()) ->
StateT s m ()
authenticate s u p r c = CMS.get >>=
(\ state -> lift $ liftIO $
writeChan (sessionChannel s)
(IEC (CEAuthenticate state u p r c)))
sendMessage :: MonadIO m => Session s m -> Message -> StateT s m ()
sendMessage s m = CMS.get >>=
(\ state -> lift $ liftIO $
writeChan (sessionChannel s)
(IEC (CEMessage state m)))
sendPresence :: MonadIO m => Session s m -> Presence -> StateT s m ()
sendPresence s p = CMS.get >>=
(\ state -> lift $ liftIO $
writeChan (sessionChannel s)
(IEC (CEPresence state p)))
sendIQ :: MonadIO m => Session s m -> IQ -> Maybe (IQ -> StateT s m Bool) -> StateT s m ()
sendIQ s i c = CMS.get >>=
(\ state -> lift $ liftIO $
writeChan (sessionChannel s)
(IEC (CEIQ state i c)))
-- xmppDisconnect :: MonadIO m => Session s m -> Maybe (s -> (Bool, s)) -> m ()
-- xmppDisconnect s c = xmppDisconnect s c
class ClientState s m where
putSession :: s -> Session s m -> s
-- =============================================================================
-- INTERNAL TYPES AND FUNCTIONS
-- =============================================================================
data XMPPError = UncaughtEvent deriving (Eq, Show)
instance CME.Error XMPPError where
strMsg "UncaughtEvent" = UncaughtEvent
type StreamID = String
-- Client actions that needs to be performed in the (main) state loop are
-- converted to ClientEvents and sent through the internal event channel.
data ClientEvent s m = CEOpenStream s N.HostName PortNumber
(OpenStreamResult -> StateT s m ()) |
CESecureWithTLS s Certificate (Certificate -> Bool)
(SecureWithTLSResult -> StateT s m ()) |
CEAuthenticate s UserName Password (Maybe Resource)
(AuthenticateResult -> StateT s m ()) |
CEMessage s Message |
CEPresence s Presence |
CEIQ s IQ (Maybe (IQ -> StateT s m Bool))
instance Show (ClientEvent s m) where
show (CEOpenStream _ h p _) = "CEOpenStream " ++ h ++ " " ++ (show p)
show (CESecureWithTLS _ c _ _) = "CESecureWithTLS " ++ c
show (CEAuthenticate _ u p r _) = "CEAuthenticate " ++ u ++ " " ++ p ++ " " ++
(show r)
show (CEIQ _ i (Just _)) = "CEIQ " ++ (show i) ++ " (with callback)"
show (CEIQ _ i Nothing) = "CEIQ " ++ (show i) ++ " (without callback)"
show (CEMessage _ m) = "CEMessage " ++ (show m)
show (CEPresence _ p) = "CEPresence " ++ (show p)
-- An XMLEvent is triggered by an XML stanza or some other XML event, and is
-- sent through the internal event channel, just like client action events.
data XMLEvent = XEBeginStream String | XEFeatures String |
XEChallenge Challenge | XESuccess Success |
XEEndStream | XEIQ IQ | XEPresence Presence |
XEMessage Message | XEProceed |
XEOther String deriving (Show)
-- instance Eq ConnectionState where
-- (==) Disconnected Disconnected = True
-- (==) ConnectedNotTLSSecured ConnectedNotTLSSecured = True
-- (==) (ConnectedTLSSecured _) (ConnectedTLSSecured _) = True
-- (==) _ _ = False
data EnumeratorEvent = EnumeratorDone |
EnumeratorXML XMLEvent |
EnumeratorException CE.SomeException
deriving (Show)
-- Type to contain the internal events.
data InternalEvent s m = IEC (ClientEvent s m) | IEE EnumeratorEvent deriving (Show)
data Challenge = Chal String deriving (Show)
data Success = Succ String deriving (Show)
data ConnectionState s m = Disconnected | Connected ServerAddress Handle
type OpenStreamCallback s m = Maybe (OpenStreamResult -> CMS.StateT s m ())
type SecureWithTLSCallback s m = Maybe (SecureWithTLSResult -> CMS.StateT s m ())
type AuthenticateCallback s m = Maybe (AuthenticateResult -> CMS.StateT s m ())
data StreamState s m = PreStream |
PreFeatures StreamProperties |
PostFeatures StreamProperties StreamFeatures
data TLSState = NoTLS | PreProceed | PreHandshake | PostHandshake TLSCtx
isTLSSecured :: TLSState -> Bool
isTLSSecured (PostHandshake _) = True
isTLSSecured _ = False
data AuthenticationState s m = NoAuthentication | AuthenticatingPreChallenge1 String String (Maybe Resource) | AuthenticatingPreChallenge2 String String (Maybe Resource) | AuthenticatingPreSuccess String String (Maybe Resource) | AuthenticatedUnbound String (Maybe Resource) | AuthenticatedBound String Resource
isConnected :: ConnectionState s m -> Bool
isConnected Disconnected = True
isConnected (Connected _ _) = True
instance Eq (ConnectionState s m) where
Disconnected == Disconnected = True
(Connected p h) == (Connected p_ h_) = p == p_ && h == h_
-- (ConnectedPostFeatures s p h t) == (ConnectedPostFeatures s p h t) = True
-- (ConnectedAuthenticated s p h t) == (ConnectedAuthenticated s p h t) = True
_ == _ = False
data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq)
data MonadIO m => State s m =
State { stateClientHandlers :: [ClientHandler s m]
, stateClientState :: s
, stateChannel :: Chan (InternalEvent s m)
, stateConnectionState :: ConnectionState s m
, stateTLSState :: TLSState
, stateStreamState :: StreamState s m
, stateOpenStreamCallback :: OpenStreamCallback s m
, stateSecureWithTLSCallback :: SecureWithTLSCallback s m
, stateAuthenticateCallback :: AuthenticateCallback s m
, stateAuthenticationState :: AuthenticationState s m
, stateResource :: Maybe Resource
, stateShouldExit :: Bool
, stateThreadID :: MVar ThreadId
, stateIQCallbacks :: [(StanzaID, (IQ -> StateT s m Bool))]
}
-- Repeatedly reads internal events from the channel and processes them. This is
-- the main loop of the XMPP session process.
-- The main loop of the XMPP library runs in the following monads:
--
-- m, m => MonadIO (from the client)
-- StateT
-- ErrorT
-- TODO: Will >> carry the updated state?
-- TODO: Should InternalState be in both places?
stateLoop :: (MonadIO m, ClientState s m) => Chan (InternalEvent s m) ->
StateT (State s m) m (Maybe CE.SomeException)
stateLoop c = do
event <- lift $ liftIO $ readChan c
lift $ liftIO $ putStrLn $ "Processing event " ++ (show event) ++ "."
result <- (processEvent event)
state <- get
case result of
Nothing -> do
case stateShouldExit state of
True ->
return $ Nothing
False ->
stateLoop c
Just e ->
return $ Just e
-- Process an InternalEvent and performs the necessary IO and updates the state
-- accordingly.
processEvent :: (MonadIO m, ClientState s m) => (InternalEvent s m) ->
(StateT (State s m) m) (Maybe CE.SomeException)
processEvent e = get >>= \ state ->
let handleOrTLSCtx = case stateTLSState state of
PostHandshake tlsCtx ->
Right tlsCtx
_ ->
let Connected _ handle = stateConnectionState state in Left handle
in case e of
-- ---------------------------------------------------------------------------
-- CLIENT EVENTS
-- ---------------------------------------------------------------------------
--
IEC (CEOpenStream clientState hostName portNumber callback) -> do
CEB.assert (stateConnectionState state == Disconnected) (return ())
let portNumber' = fromIntegral portNumber
connectResult <- liftIO $ CE.try $ N.connectTo hostName
(N.PortNumber portNumber')
case connectResult of
Right handle -> do
put $ state { stateConnectionState = Connected (ServerAddress hostName portNumber') handle
, stateStreamState = PreStream
, stateOpenStreamCallback = Just callback }
lift $ liftIO $ hSetBuffering handle NoBuffering
lift $ liftIO $ send ("") (Left handle)
threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Left handle)
lift $ liftIO $ putMVar (stateThreadID state) threadID
return Nothing
Left e -> do
((), clientState') <- lift $ runStateT (callback OpenStreamFailure) clientState
put $ state { stateShouldExit = True }
return $ Just e
IEC (CESecureWithTLS clientState certificate verifyCertificate callback) -> do
-- CEB.assert (not $ isTLSSecured (stateStreamState state)) (return ())
let Connected _ handle = stateConnectionState state
lift $ liftIO $ send "" (Left handle)
put $ state { stateStreamState = PreStream
, stateSecureWithTLSCallback = Just callback }
return Nothing
-- TODO: Save callback in state.
IEC (CEAuthenticate clientState userName password resource callback) -> do
-- CEB.assert (or [ stateConnectionState state == Connected
-- , stateConnectionState state == TLSSecured ]) (return ())
-- CEB.assert (stateHandle state /= Nothing) (return ())
put $ state { stateAuthenticationState = AuthenticatingPreChallenge1 userName password resource
, stateAuthenticateCallback = Just callback }
lift $ liftIO $ send "" handleOrTLSCtx
return Nothing
IEE (EnumeratorXML (XEBeginStream stream)) -> do
put $ state { stateStreamState = PreFeatures (1.0) }
return Nothing
IEE (EnumeratorXML (XEFeatures features)) -> do
let PreFeatures streamProperties = stateStreamState state
case stateTLSState state of
NoTLS -> let callback = fromJust $ stateOpenStreamCallback state in do
((), clientState) <- lift $ runStateT (callback $ OpenStreamSuccess streamProperties "TODO") (stateClientState state)
put $ state { stateClientState = clientState
, stateStreamState = PostFeatures streamProperties "TODO" }
return Nothing
_ -> case stateAuthenticationState state of
AuthenticatedUnbound _ resource -> do -- TODO: resource
case resource of
Nothing -> do
lift $ liftIO $ send ("") handleOrTLSCtx
return ()
_ -> do
lift $ liftIO $ send ("" ++ fromJust resource ++ "") handleOrTLSCtx
return ()
r <- lift $ liftIO $ getID
lift $ liftIO $ send ("" ++ "") handleOrTLSCtx
-- TODO: Execute callback on iq result
let callback = fromJust $ stateAuthenticateCallback state in do -- TODO: streamProperties "TODO" after success
((), clientState) <- lift $ runStateT (callback $ AuthenticateSuccess streamProperties "TODO" "todo") (stateClientState state) -- get proper resource value when moving to iq result
put $ state { stateClientState = clientState
, stateStreamState = PostFeatures streamProperties "TODO" }
return Nothing
_ -> do
let callback = fromJust $ stateSecureWithTLSCallback state in do
((), clientState) <- lift $ runStateT (callback $ SecureWithTLSSuccess streamProperties "TODO") (stateClientState state)
put $ state { stateClientState = clientState
, stateStreamState = PostFeatures streamProperties "TODO" }
return Nothing
-- TODO: Can we assume that it's safe to start to enumerate on handle when it
-- might not have exited?
IEE (EnumeratorXML XEProceed) -> do
let Connected (ServerAddress hostName _) handle = stateConnectionState state
tlsCtx <- lift $ liftIO $ handshake' handle hostName
let tlsCtx_ = fromJust tlsCtx
put $ (defaultState (stateChannel state) (stateThreadID state) (stateClientHandlers state) (stateClientState state)) { stateTLSState = PostHandshake tlsCtx_, stateConnectionState = (stateConnectionState state), stateSecureWithTLSCallback = (stateSecureWithTLSCallback state) }
threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Right tlsCtx_) -- double code
lift $ liftIO $ putStrLn "00000000000000000000000000000000"
lift $ liftIO $ swapMVar (stateThreadID state) threadID -- return value not used
lift $ liftIO $ putStrLn "00000000000000000000000000000000"
lift $ liftIO $ threadDelay 1000000
lift $ liftIO $ putStrLn "00000000000000000000000000000000"
lift $ liftIO $ send ("") (Right tlsCtx_)
lift $ liftIO $ putStrLn "00000000000000000000000000000000"
return Nothing
IEE (EnumeratorXML (XEChallenge (Chal challenge))) -> do
let serverHost = "jonkristensen.com"
let challenge' = CBBS.decode challenge
case stateAuthenticationState state of
AuthenticatingPreChallenge1 userName password resource -> do
-- This is the first challenge - we need to calculate the reply
random <- lift $ liftIO $ getID -- TODO: Length and content.
case replyToChallenge1 challenge' serverHost userName password random of
Left reply -> do
let reply' = (filter (/= '\n') (CBBS.encode reply))
lift $ liftIO $ send ("" ++ reply' ++ "") handleOrTLSCtx
put $ state { stateAuthenticationState = AuthenticatingPreChallenge2 userName password resource }
return ()
Right error -> do
lift $ liftIO $ putStrLn $ show error
return ()
AuthenticatingPreChallenge2 userName password resource -> do
-- This is not the first challenge; [...]
-- TODO: Can we assume "rspauth"?
lift $ liftIO $ send "" handleOrTLSCtx
put $ state { stateAuthenticationState = AuthenticatingPreSuccess userName password resource }
return ()
return Nothing
-- We have received a SASL "success" message over a secured connection
-- TODO: Parse the success message?
-- TODO: ?
IEE (EnumeratorXML (XESuccess (Succ _))) -> do
let serverHost = "jonkristensen.com"
let AuthenticatingPreSuccess userName _ resource = stateAuthenticationState state in do
lift $ liftIO $ send ("") handleOrTLSCtx
put $ state { stateAuthenticationState = AuthenticatedUnbound userName resource }
return Nothing
IEE EnumeratorDone ->
-- TODO: Exit?
return Nothing
-- ---------------------------------------------------------------------------
-- XML EVENTS
-- ---------------------------------------------------------------------------
-- Ignore id="bind_1" and session IQ result, otherwise create client event
IEE (EnumeratorXML (XEIQ iqEvent)) -> do
case shouldIgnoreIQ iqEvent of
True ->
return Nothing
False -> do
let iqReceivedFunctions = map (\ x -> iqReceived x) (stateClientHandlers state)
let functions = map (\ x -> case x of
Just f -> Just (f iqEvent)
Nothing -> Nothing) iqReceivedFunctions
let functions' = case lookup (fromJust $ stanzaID $ iqStanza $ iqEvent) (stateIQCallbacks state) of
Just f -> (Just (f iqEvent)):functions
Nothing -> functions
let clientState = stateClientState state -- ClientState s m
clientState' <- sendToClient functions' clientState
put $ state { stateClientState = clientState' }
return Nothing
IEE (EnumeratorXML (XEPresence presenceEvent)) -> do
let presenceReceivedFunctions = map (\ x -> presenceReceived x) (stateClientHandlers state)
let functions = map (\ x -> case x of
Just f -> Just (f presenceEvent)
Nothing -> Nothing) presenceReceivedFunctions
let clientState = stateClientState state -- ClientState s m
clientState' <- sendToClient functions clientState
put $ state { stateClientState = clientState' }
return Nothing
IEE (EnumeratorXML (XEMessage messageEvent)) -> do
let messageReceivedFunctions = map (\ x -> messageReceived x) (stateClientHandlers state)
let functions = map (\ x -> case x of
Just f -> Just (f messageEvent)
Nothing -> Nothing) messageReceivedFunctions
let clientState = stateClientState state -- ClientState s m
clientState' <- sendToClient functions clientState
put $ state { stateClientState = clientState' }
return Nothing
IEC (CEPresence clientState presence) -> do
presence' <- case stanzaID $ presenceStanza presence of
Nothing -> do
id <- lift $ liftIO $ getID
return $ presence { presenceStanza = (presenceStanza presence) { stanzaID = Just (SID id) } }
_ -> return presence
let xml = presenceToXML presence'
lift $ liftIO $ send xml handleOrTLSCtx
return Nothing
IEC (CEMessage clientState message) -> do
message' <- case stanzaID $ messageStanza message of
Nothing -> do
id <- lift $ liftIO $ getID
return $ message { messageStanza = (messageStanza message) { stanzaID = Just (SID id) } }
_ -> return message
let xml = messageToXML message'
lift $ liftIO $ send xml handleOrTLSCtx
return Nothing
IEC (CEIQ clientState iq callback) -> do
iq' <- case stanzaID $ iqStanza iq of
Nothing -> do
id <- lift $ liftIO $ 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
case callback of
Just callback' -> case iq of
IQGet {} -> put $ state { stateIQCallbacks = (fromJust $ stanzaID $ iqStanza iq', callback'):(stateIQCallbacks state) }
IQSet {} -> put $ state { stateIQCallbacks = (fromJust $ stanzaID $ iqStanza iq', callback'):(stateIQCallbacks state) }
_ -> return ()
Nothing -> return ()
-- TODO: Bind ID to callback
let xml = iqToXML iq'
lift $ liftIO $ send xml handleOrTLSCtx
return Nothing
-- XOEDisconnect -> do
-- -- TODO: Close stream
-- return ()
e -> do
return Nothing
-- lift $ liftIO $ putStrLn $ "UNCAUGHT EVENT: " ++ (show e)
-- return $ Just (CE.SomeException $ CE.PatternMatchFail "processEvent")
where
-- Assumes handle is set
send :: String -> Either Handle TLSCtx -> IO ()
send s o = case o of
Left handle -> do
liftIO $ hPutStr handle $ encodeString $ s
liftIO $ hFlush handle
return ()
Right tlsCtx -> do
liftIO $ sendData tlsCtx $ DBLC.pack $ encodeString s
return ()
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
sendToClient :: (MonadIO m, ClientState s m) => [Maybe (StateT s m Bool)] -> s -> (StateT (State s m) m) s
sendToClient [] s = return s
sendToClient (Nothing:fs) s = sendToClient fs s
sendToClient ((Just f):fs) s = do
(b, s') <- lift $ runStateT f s
case b of
True -> return s'
False -> sendToClient fs s'
-- Reads from the provided handle or TLS context and sends the events to the
-- internal event channel.
xmlEnumerator :: Chan (InternalEvent s m) -> Either Handle TLSCtx -> IO ()
xmlEnumerator c s = do
enumeratorResult <- case s of
Left handle -> run $ enumHandle 1 handle $$ joinI $
parseBytes decodeEntities $$ xmlReader c
Right tlsCtx -> run $ enumTLS tlsCtx $$ joinI $
parseBytes decodeEntities $$ xmlReader c
case enumeratorResult of
Right _ ->
writeChan c $ IEE EnumeratorDone
Left e ->
writeChan c $ IEE (EnumeratorException e)
where
-- Behaves like enumHandle, but reads from the TLS context instead
enumTLS :: TLSCtx -> E.Enumerator DB.ByteString IO b
enumTLS c s = loop c s
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
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
putStrLn ">>>>TLS data sended<<<<"
return (Just c)
Left ge -> do
putStrLn $ show ge
return Nothing
xmlReader :: Chan (InternalEvent s m) -> Iteratee Event IO (Maybe Event)
xmlReader c = xmlReader_ c [] 0
xmlReader_ :: Chan (InternalEvent s m) -> [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 $ IEE $ EnumeratorXML $ XEBeginStream $ "StreamTODO"
xmlReader_ ch [] 1
xmlReader_ ch [EventEndElement name] 1
| namePrefix name == Just (DT.pack "stream") &&
nameLocalName name == DT.pack "stream" = do
liftIO $ writeChan ch $ IEE $ EnumeratorXML $ 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" = do
liftIO $ writeChan ch $ IEE $ EnumeratorXML $ XEProceed
E.yield Nothing (E.Chunks [])
| otherwise = do
-- liftIO $ putStrLn "Got an IEX Event..."
liftIO $ writeChan ch $ IEE $ EnumeratorXML $ (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 "FeaturesTODO"
| 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 = "" ++
(elementsToString $ presencePayload p) ++ ""
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 "" ++ (elementToString (Just p)) ++ ""
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 "" ++ (elementToString (Just p)) ++ ""
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 "" ++ (elementToString p) ++ ""
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 = "" ++
(elementsToString $ messagePayload m) ++ ""
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) ++ "'"
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