@ -15,139 +15,230 @@
@@ -15,139 +15,230 @@
module Network.XMPP.Session (
XMPPT ( runXMPPT )
, hookStreamsOpenedEvent
, hookDisconnectedEvent
, destroy
, openStreams
, create
, DisconnectReason
) where
import Network.XMPP.Types
import Network.XMPP.Utilities
import Control.Concurrent ( Chan , readChan , writeChan )
import Control.Concurrent ( Chan , newChan , readChan , writeChan )
import Control.Monad.IO.Class ( MonadIO , liftIO )
import Data.Certificate.X509 ( X509 )
import Data.Dynamic ( Dynamic )
import Control.Monad.Reader ( MonadReader , ReaderT , ask )
-- import Control.Monad.Reader (MonadReader, ReaderT, ask)
import Control.Monad.State.Lazy ( MonadState , StateT , get , put , execStateT )
import qualified Control.Exception as CE
import qualified Network as N
import System.IO ( BufferMode , BufferMode ( NoBuffering ) )
import GHC.IO.Handle ( Handle , hPutStr , hFlush , hSetBuffering , hWaitForInput )
import Codec.Binary.UTF8.String
-- |
-- The XMPP monad transformer. XMPP clients will need to operate in this
-- The XMPP monad transformer. Contains internal state in order to
-- work with Pontarius. Pontarius clients needs to operate in this
-- context.
newtype XMPPT m a
= XMPPT { runXMPPT :: ReaderT ( ReaderState m ) m a }
deriving ( Monad , MonadIO )
newtype XMPPT m a = XMPPT { runXMPPT :: StateT ( State m ) m a } deriving ( Monad , MonadIO )
deriving instance ( Monad m , MonadIO m ) => MonadReader ( ReaderState m ) ( XMPPT m )
-- Make XMPPT derive the Monad and MonadIO instances.
data ReaderState m = ReaderState { intEvtChan :: Chan InternalEvent
, hookModChan :: Chan ( HookModification m ) }
deriving instance ( Monad m , MonadIO m ) => MonadState ( State m ) ( XMPPT m )
-- |
-- Events that may be emitted from Pontarius XMPP.
create :: MonadIO m => XMPPT m () -> m ()
data ConnectedEvent = ConnectedEvent ( Either ConnectedFailureReason Resource )
create main = do
chan <- liftIO $ newChan
idGen <- liftIO $ idGenerator " "
execStateT ( runXMPPT init ) ( State chan idGen [] )
return ()
where
init = do
main
stateLoop
data HookId = HookId String
-- We need a channel because multiple threads needs to append events,
-- and we need to wait for events when there are none.
data State m = State { evtChan :: Chan ( InternalEvent m )
, hookIdGenerator :: IdGenerator
, streamsOpenedHooks :: [ ( HookId , ( Maybe OpenStreamsFailureReason -> XMPPT m Bool , Maybe ( Maybe OpenStreamsFailureReason -> XMPPT m Bool ) ) ) ] }
-- data DynamicEvent = forall a. Dynamic a => DynamicEvent a
data DynamicEvent = DynamicEvent Dynamic
type OpenedStreamsEvent = Maybe OpenStreamsFailureReason
-- Internal events - events to be processed within Pontarius.
type TLSSecuredEvent = Maybe TLSSecureFailureReason
-- data InternalEvent s m = IEC (ClientEvent s m) | IEE EnumeratorEvent | IET (TimeoutEvent s m) deriving (Show)
type AuthenticatedEvent = Either AuthenticateFailureReason Resource
data InternalEvent m
= OpenStreamsEvent HostName PortNumber
-- | DisconnectEvent
| RegisterStreamsOpenedHook ( Maybe OpenStreamsFailureReason -> XMPPT m Bool ) ( Maybe ( OpenStreamsFailureReason -> Bool ) )
-- | IEEE EnumeratorEvent
--data Event
-- = ConnectedEvent (Either IntFailureReason Resource)
-- -- | OpenedStreamsEvent (Maybe OpenStreamsFailureReason)
-- -- | TLSSecuredEvent (Maybe TLSSecuringFailureReason)
-- -- | AuthenticatedEvent (Either AuthenticationFailureReason Resource)
-- -- | DisconnectEvent DisconnectReason
-- -- | MessageEvent (Either MessageError Message)
-- -- | PresenceEvent (Either PresenceError Presence)
-- -- | IQEvent (Either IQResult IQRequest)
instance Show ( InternalEvent m ) where
show _ = " InternalEvent "
-- |
-- Events that may be emitted from Pontarius.
data Event = -- ConnectedEvent (Either IntFailureReason Resource)
{- | -} OpenedStreamsEvent ( Maybe OpenStreamsFailureReason )
-- | TLSSecuredEvent (Maybe TLSSecuringFailureReason)
-- | AuthenticatedEvent (Either AuthenticationFailureReason Resource)
| DisconnectedEvent DisconnectReason
-- | MessageEvent (Either MessageError Message)
-- | PresenceEvent (Either PresenceError Presence)
-- | IQEvent (Either IQResult IQRequest)
-- | forall a. Dynamic a => DynamicEvent a
-- deriving (Show)
deriving ( Show )
-- data DynamicEvent = forall a. Dynamic a => DynamicEvent a
-- data DynamicEvent = DynamicEvent Dynamic
-- data ConnectedFailureReason
-- = COSFR OpenStreamsFailureReason
-- | CTSFR TLSSecureFailureReason
-- | CAFR AuthenticateFailureReason
data ConnectedFailureReason
= COSFR OpenStreamsFailureReason
| CTSFR TLSSecureFailureReason
| CAFR AuthenticateFailureReason
-- TODO: Possible ways opening a stream can fail.
data OpenStreamsFailureReason = OpenStreamFailureReason deriving ( Show )
data OpenStreamsFailureReason = OpenStreamFailureReason
-- data TLSSecureFailureReason = TLSSecure FailureReason
data TLSSecureFailureReason = TLSSecureFailureReason
-- data AuthenticateFailureReason = AuthenticateFailureReason
data DisconnectReason = DisconnectReason deriving ( Show )
data AuthenticateFailureReason = AuthenticateFailureReason
-- The "hook modification" events have a higher priority than other events, and
-- are thus sent through a Chan of their own. The boolean returns value signals
-- whether or not the hook should be removed.
data HookModification m
= MonadIO m => RegisterConnectedHook ( ConnectedEvent -> XMPPT m Bool ) ( Maybe ( ConnectedEvent -> Bool ) )
| RegisterStreamsOpenedHook ( OpenedStreamsEvent -> XMPPT m Bool ) ( Maybe ( OpenedStreamsEvent -> Bool ) )
| RegisterTLSSecuredHook ( TLSSecuredEvent -> XMPPT m Bool ) ( Maybe ( TLSSecuredEvent -> Bool ) )
| RegisterAuthenticatedHook ( AuthenticatedEvent -> XMPPT m Bool ) ( Maybe ( AuthenticatedEvent -> Bool ) )
-- | forall a. Dynamic a => RegisterDynamicHook (DynamicEvent a -> XMPPT m Bool)
| RegisterDynamicHook ( DynamicEvent -> XMPPT m Bool ) ( Maybe ( DynamicEvent -> Bool ) )
-- data HookModification m
-- = MonadIO m => -- RegisterConnectedHook (ConnectedEvent -> XMPPT m Bool) (Maybe (ConnectedEvent -> Bool))
-- | RegisterTLSSecuredHook (TLSSecuredEvent -> XMPPT m Bool) (Maybe (TLSSecuredEvent -> Bool))
-- | RegisterAuthenticatedHook (AuthenticatedEvent -> XMPPT m Bool) (Maybe (AuthenticatedEvent -> Bool))
-- -- | forall a. Dynamic a => RegisterDynamicHook (DynamicEvent a -> XMPPT m Bool)
-- | RegisterDynamicHook (DynamicEvent -> XMPPT m Bool) (Maybe (DynamicEvent -> Bool))
data State = State
-- Reads an event from the internal event channel, processes it,
-- performs the generated impure actions, and loops.
stateLoop :: State -> Chan InternalEvent -> IO ()
stateLoop :: MonadIO m => XMPPT m ()
stateLoop s c = do
ie <- readChan c
let ( s' , ios ) = processInternalEvent s ie in
-- forall ios, execute it
stateLoop s' c
stateLoop = do
rs <- get
event <- liftIO $ readChan $ evtChan rs
liftIO $ putStrLn $ " Processing " ++ ( show event ) ++ " ... "
actions <- processEvent event
sequence actions
stateLoop
processInternalEvent :: State -> InternalEvent -> ( State , [ IO () ] )
-- Processes an internal event and generates a list of impure actions.
processInternalEvent s ie = ( s , [ connectIO ] )
processEvent :: MonadIO m => InternalEvent m -> XMPPT m [ XMPPT m ( IO () ) ]
processEvent ( OpenStreamsEvent h p ) = return [ openStreamAction h p ]
where
openStreamAction :: MonadIO m => HostName -> PortNumber -> XMPPT m ( IO () )
openStreamAction h p = do
-- CEB.assert (stateConnectionState state == Disconnected) (return ())
let p' = fromIntegral p
handle <- liftIO $ {- CE.try $ -} N . connectTo h ( N . PortNumber p' )
return $ liftIO $ do -- $ case result of
-- Right handle -> do
hSetBuffering handle NoBuffering
hPutStr handle $ encodeString " <?xml version='1.0'?><stream:stream to=' " ++ h ++ " ' version='1.0' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams'> "
hFlush handle
return ()
-- -- threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Left handle)
-- -- lift $ liftIO $ putMVar (stateThreadID state) threadID
-- Left error -> do
-- -- let clientState = stateClientState state
-- -- ((), clientState') <- lift $ runStateT (callback OpenStreamFailure) clientState
-- -- put $ state { stateShouldExit = True }
-- -- return $ Just e
-- return $ Just error
-- hookConnectedEvent :: MonadIO m => (ConnectedEvent -> XMPPT m Bool) -> (Maybe (ConnectedEvent -> Bool)) -> XMPPT m ()
connectIO :: IO ()
connectIO = return ()
-- hookConnectedEvent cb pred = ask >>= \rs -> liftIO $ writeChan (hookModChan rs) (RegisterConnectedHook cb pred)
hookConnectedEvent :: MonadIO m => ( ConnectedEvent -> XMPPT m Bool ) -> ( Maybe ( ConnectedEvent -> Bool ) ) -> XMPPT m ()
-- | Hook the provided callback and (optional) predicate to the
-- "Streams Opened" event.
hookConnectedEvent cb pred = ask >>= \ rs -> liftIO $ writeChan ( hookModChan rs ) ( RegisterConnectedHook cb pred )
hookStreamsOpenedEvent :: MonadIO m => ( Maybe OpenStreamsFailureReason -> XMPPT m Bool ) -> ( Maybe ( Maybe OpenStreamsFailureReason -> XMPPT m Bool ) ) -> XMPPT m HookId
hookStreamsOpenedEvent cb pred = do
rs <- get
hookId <- liftIO $ nextId $ hookIdGenerator rs
put $ rs { streamsOpenedHooks = ( HookId hookId , ( cb , pred ) ) : streamsOpenedHooks rs }
return $ HookId hookId
hookDynamicEvent :: MonadIO m => ( DynamicEvent -> XMPPT m Bool ) -> ( Maybe ( DynamicEvent -> Bool ) ) -> XMPPT m ()
hookDynamicEvent cb pred = ask >>= \ rs -> liftIO $ writeChan ( hookModChan rs ) ( RegisterDynamicHook cb pred )
hookDisconnectedEvent :: MonadIO m => ( DisconnectReason -> XMPPT m Bool ) -> ( Maybe ( DisconnectReason -> XMPPT m Bool ) ) -> XMPPT m HookId
hookDisconnectedEvent cb pred = do
rs <- get
hookId <- liftIO $ nextId $ hookIdGenerator rs
-- TODO: Actually hook it.
return $ HookId hookId
hookStreamsOpenedEvent :: MonadIO m => ( OpenedStreamsEvent -> XMPPT m Bool ) -> ( Maybe ( OpenedStreamsEvent -> Bool ) ) -> XMPPT m ()
-- hookTLSSecuredEvent :: MonadIO m => (TLSSecuredEvent -> XMPPT m Bool) -> (Maybe (TLSSecuredEvent -> Bool)) -> XMPPT m ()
hookStreamsOpenedEvent cb pred = ask >>= \ rs -> liftIO $ writeChan ( hookModChan rs ) ( RegisterStreamsOpenedHook cb pred )
-- hookTLSSecuredEvent cb pred = ask >>= \rs -> liftIO $ writeChan (hookModChan rs) (RegisterTLSSecuredHook cb pred )
hookTLSSecuredEvent :: MonadIO m => ( TLSSecuredEvent -> XMPPT m Bool ) -> ( Maybe ( TLSSecuredEvent -> Bool ) ) -> XMPPT m ()
-- hookAuthenticatedEvent :: MonadIO m => (AuthenticatedEvent -> XMPPT m Bool) -> (Maybe (AuthenticatedEvent -> Bool)) -> XMPPT m ()
hookTLSSecuredEvent cb pred = ask >>= \ rs -> liftIO $ writeChan ( hookModChan rs ) ( RegisterTLSSecuredHook cb pred )
-- hookAuthenticatedEvent cb pred = ask >>= \rs -> liftIO $ writeChan (hookModChan rs) (RegisterAuthenticatedHook cb pred )
hookAuthenticatedEvent :: MonadIO m => ( AuthenticatedEvent -> XMPPT m Bool ) -> ( Maybe ( AuthenticatedEvent -> Bool ) ) -> XMPPT m ()
-- hookDynamicEvent :: MonadIO m => (DynamicEvent -> XMPPT m Bool) -> (Maybe (DynamicEvent -> Bool)) -> XMPPT m ()
hookAuthenticatedEvent cb pred = ask >>= \ rs -> liftIO $ writeChan ( hookModChan rs ) ( RegisterAuthenticatedHook cb pred )
-- hookDynamicEvent cb pred = ask >>= \rs -> liftIO $ writeChan (hookModChan rs) (RegisterDynamicHook cb pred )
openStreams = openStreams
tlsSecure = tlsSecure
authenticate = authenticate
-- | Asynchronously request to open a stream to an XMPP server on the
-- given host name and port.
openStreams :: MonadIO m => HostName -> PortNumber -> XMPPT m ()
openStreams h p = get >>= \ rs -> liftIO $ writeChan ( evtChan rs ) ( OpenStreamsEvent h p )
destroy = destroy
-- tlsSecure = tlsSecure
-- authenticate = authenticate
-- fireConnectedEvent = fireConnectedEvent
fireConnectedEvent = fireConnectedEvent
-- |
-- connect is implemented using hookStreamOpenedEvent, hookTLSSecuredEvent, and
@ -168,96 +259,96 @@ fireConnectedEvent = fireConnectedEvent
@@ -168,96 +259,96 @@ fireConnectedEvent = fireConnectedEvent
-- authenticate will not be used by the client. Calling those functions may
-- generate events that can cause connect to behave incorrectly.
connect :: MonadIO m => HostName -> PortNumber -> Maybe ( Maybe [ X509 ] , ( [ X509 ] -> Bool ) ) -> Maybe ( UserName , Password , Maybe Resource ) -> XMPPT m ()
connect h p Nothing Nothing = do
hookStreamsOpenedEvent onStreamsOpenedEvent Nothing
openStreams h p
where
onStreamsOpenedEvent Nothing = do
fireConnectedEvent Nothing
return False
onStreamsOpenedEvent ( Just e ) = do
fireConnectedEvent $ Left $ COSFR e
return False
connect h p ( Just t ) Nothing = do
hookStreamsOpenedEvent onStreamsOpenedEvent Nothing
openStreams h p
where
onStreamsOpenedEvent Nothing = do
hookTLSSecuredEvent onTLSSecuredEvent Nothing
tlsSecure
return False
onStreamsOpenedEvent ( Just e ) = do
fireConnectedEvent $ Left $ COSFR e
return False
onTLSSecuredEvent Nothing = do
fireConnectedEvent Nothing
return False
onTLSSecuredEvent ( Just e ) = do
fireConnectedEvent $ Left $ CTSFR e
return False
connect h p Nothing ( Just a ) = do
hookStreamsOpenedEvent onStreamsOpenedEvent Nothing
openStreams h p
where
onStreamsOpenedEvent Nothing = do
hookAuthenticatedEvent onAuthenticatedEvent Nothing
authenticate
return False
onStreamsOpenedEvent ( Just e ) = do
fireConnectedEvent $ Left $ COSFR e
return False
onAuthenticatedEvent ( Right r ) = do
fireConnectedEvent $ Just r
return False
onAuthenticated ( Left e ) = do
fireConnectedEvent $ Left $ CAFR e
return False
connect h p ( Just t ) ( Just a ) = do
hookStreamsOpenedEvent onStreamsOpenedEvent Nothing
openStreams h p
where
onStreamsOpenedEvent Nothing = do
hookTLSSecuredEvent onTLSSecuredEvent Nothing
tlsSecure
return False
onStreamsOpenedEvent ( Just e ) = do
fireConnectedEvent $ Left $ COSFR e
return False
onTLSSecuredEvent Nothing = do
hookAuthenticatedEvent onAuthenticatedEvent Nothing
authenticate
return False
onTLSSecuredEvent ( Just e ) = do
fireConnectedEvent $ Left $ CTSFR e
return False
onAuthenticatedEvent ( Right r ) = do
fireConnectedEvent $ Just r
return False
onAuthenticated ( Left e ) = do
fireConnectedEvent $ Left $ CAFR e
return False
-- connect :: MonadIO m => HostName -> PortNumber -> Maybe (Maybe [X509], ([X509] -> Bool)) -> Maybe (UserName, Password, Maybe Resource) -> XMPPT m ()
--
-- connect h p Nothing Nothing = do
-- hookStreamsOpenedEvent onStreamsOpenedEvent Nothing
-- openStreams h p
--
-- where
--
-- onStreamsOpenedEvent Nothing = do
-- fireConnectedEvent Nothing
-- return False
--
-- onStreamsOpenedEvent (Just e) = do
-- fireConnectedEvent $ Left $ COSFR e
-- return False
--
-- connect h p (Just t) Nothing = do
-- hookStreamsOpenedEvent onStreamsOpenedEvent Nothing
-- openStreams h p
--
-- where
--
-- onStreamsOpenedEvent Nothing = do
-- hookTLSSecuredEvent onTLSSecuredEvent Nothing
-- tlsSecure
-- return False
--
-- onStreamsOpenedEvent (Just e) = do
-- fireConnectedEvent $ Left $ COSFR e
-- return False
--
-- onTLSSecuredEvent Nothing = do
-- fireConnectedEvent Nothing
-- return False
--
-- onTLSSecuredEvent (Just e) = do
-- fireConnectedEvent $ Left $ CTSFR e
-- return False
--
-- connect h p Nothing (Just a) = do
-- hookStreamsOpenedEvent onStreamsOpenedEvent Nothing
-- openStreams h p
--
-- where
--
-- onStreamsOpenedEvent Nothing = do
-- hookAuthenticatedEvent onAuthenticatedEvent Nothing
-- authenticate
-- return False
--
-- onStreamsOpenedEvent (Just e) = do
-- fireConnectedEvent $ Left $ COSFR e
-- return False
--
-- onAuthenticatedEvent (Right r) = do
-- fireConnectedEvent $ Just r
-- return False
--
-- onAuthenticated (Left e) = do
-- fireConnectedEvent $ Left $ CAFR e
-- return False
--
-- connect h p (Just t) (Just a) = do
-- hookStreamsOpenedEvent onStreamsOpenedEvent Nothing
-- openStreams h p
--
-- where
--
-- onStreamsOpenedEvent Nothing = do
-- hookTLSSecuredEvent onTLSSecuredEvent Nothing
-- tlsSecure
-- return False
--
-- onStreamsOpenedEvent (Just e) = do
-- fireConnectedEvent $ Left $ COSFR e
-- return False
--
-- onTLSSecuredEvent Nothing = do
-- hookAuthenticatedEvent onAuthenticatedEvent Nothing
-- authenticate
-- return False
--
-- onTLSSecuredEvent (Just e) = do
-- fireConnectedEvent $ Left $ CTSFR e
-- return False
--
-- onAuthenticatedEvent (Right r) = do
-- fireConnectedEvent $ Just r
-- return False
--
-- onAuthenticated (Left e) = do
-- fireConnectedEvent $ Left $ CAFR e
-- return False
Jon Kristensen
14 years ago