Browse Source

initial work on the new Session module; defines a XMPPT monad that derives from Monad and MonadReader, shows what events there are, how hooks are set, and provides a convenience function for connecting

master
Jon Kristensen 14 years ago
parent
commit
542520e4d5
  1. 46
      Network/XMPP.hs
  2. 167
      Network/XMPP/Session.hs
  3. 16
      Network/XMPP/Stream.hs
  4. 57
      Network/XMPP/Types.hs

46
Network/XMPP.hs

@ -35,27 +35,27 @@ module Network.XMPP ( -- Network.XMPP.JID
, fromStrings , fromStrings
-- Network.XMPP.Session -- Network.XMPP.Session
, ClientHandler (..) -- , ClientHandler (..)
, ClientState (..) -- , ClientState (..)
, ConnectResult (..) -- , ConnectResult (..)
, HostName -- , HostName
, Password -- , Password
, PortNumber -- , PortNumber
, Resource -- , Resource
, Session -- , Session
, TerminationReason -- , TerminationReason
, UserName -- , UserName
, sendIQ -- , sendIQ
, sendPresence -- , sendPresence
, sendMessage -- , sendMessage
, connect -- , connect
, openStreams -- , openStreams
, tlsSecureStreams -- , tlsSecureStreams
, authenticate -- , authenticate
, session -- , session
, OpenStreamResult (..) -- , OpenStreamResult (..)
, SecureWithTLSResult (..) -- , SecureWithTLSResult (..)
, AuthenticateResult (..) -- , AuthenticateResult (..)
-- Network.XMPP.Stanza -- Network.XMPP.Stanza
, StanzaID (SID) , StanzaID (SID)
@ -68,9 +68,7 @@ module Network.XMPP ( -- Network.XMPP.JID
, Presence (..) , Presence (..)
, IQ (..) , IQ (..)
, iqPayloadNamespace , iqPayloadNamespace
, iqPayload , iqPayload ) where
, injectAction ) where
import Network.XMPP.Address import Network.XMPP.Address
import Network.XMPP.SASL import Network.XMPP.SASL

167
Network/XMPP/Session.hs

@ -4,57 +4,82 @@
-- TODO: Predicates on callbacks? -- TODO: Predicates on callbacks?
-- TODO: . vs $ -- TODO: . vs $
-- TODO: type XMPP = XMPPT IO? + runXMPP
module Network.XMPP.NewSession ( {-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
module Network.XMPP.Session (
XMPPT (runXMPPT) XMPPT (runXMPPT)
) where ) where
import Network.XMPP.Types
import Control.Concurrent (Chan, 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)
-- | -- |
-- The XMPP monad transformer. XMPP clients will need to operate in this -- The XMPP monad transformer. XMPP clients will need to operate in this
-- context. -- context.
data XMPPT m a = XMPPT { runXMPPT :: XMPPT m a -> m a newtype XMPPT m a
, internalEventChan :: Chan InternalEvent = XMPPT { runXMPPT :: ReaderT (ReaderState m) m a }
, hookModificationsChan :: Chan HookModification } deriving (Monad, MonadIO)
deriving instance (Monad m, MonadIO m) => MonadReader (ReaderState m) (XMPPT m)
data ReaderState m = ReaderState { intEvtChan :: Chan InternalEvent
, hookModChan :: Chan (HookModification m) }
-- | -- |
-- Events that may be emitted from Pontarius XMPP. -- Events that may be emitted from Pontarius XMPP.
data Event data ConnectedEvent = ConnectedEvent (Either ConnectedFailureReason Resource)
= ConnectedEvent (Either ConnectionFailureReason 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)
-- data DynamicEvent = forall a. Dynamic a => DynamicEvent a
data DynamicEvent = DynamicEvent Dynamic
data ConnectedFailureReason type OpenedStreamsEvent = Maybe OpenStreamsFailureReason
= COSFR -- OpenStreamFailureReason
| CTSFR -- TLSSecureFailureReason
| CAFR -- AuthenticateFailureReason
type TLSSecuredEvent = Maybe TLSSecureFailureReason
-- data OpenStreamFailureReason type AuthenticatedEvent = Either AuthenticateFailureReason Resource
-- data TLSSecureFailureReason --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)
-- | forall a. Dynamic a => DynamicEvent a
-- deriving (Show)
-- data AuthenticateFailureReason
data ConnectedFailureReason
= COSFR OpenStreamsFailureReason
| CTSFR TLSSecureFailureReason
| CAFR AuthenticateFailureReason
-- Internal events processed in the main state loop of Pontarius XMPP. They are data OpenStreamsFailureReason = OpenStreamFailureReason
-- either received from the client or from the enumerator.
data InternalEvent data TLSSecureFailureReason = TLSSecureFailureReason
= IECE ClientEvent
| IEEE EnumeratorEvent data AuthenticateFailureReason = AuthenticateFailureReason
-- The "hook modification" events have a higher priority than other events, and -- The "hook modification" events have a higher priority than other events, and
@ -62,8 +87,15 @@ data InternalEvent
-- whether or not the hook should be removed. -- whether or not the hook should be removed.
data HookModification m data HookModification m
= RegisterConnectedHook (ConnectedEvent -> XMPPT m Bool) = MonadIO m => RegisterConnectedHook (ConnectedEvent -> XMPPT m Bool) (Maybe (ConnectedEvent -> Bool))
| forall a. Dynamic a => RegisterDynamicHook (DynamicEvent a -> XMPPT m 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 State = State
stateLoop :: State -> Chan InternalEvent -> IO () stateLoop :: State -> Chan InternalEvent -> IO ()
@ -85,30 +117,37 @@ processInternalEvent s ie = (s, [connectIO])
connectIO = return () connectIO = return ()
hookConnectedEvent :: (ConnectedEvent -> XMPPT m Bool) -> XMPPT m () hookConnectedEvent :: MonadIO m => (ConnectedEvent -> XMPPT m Bool) -> (Maybe (ConnectedEvent -> Bool)) -> XMPPT m ()
hookConnectedEvent cb pred = ask >>= \rs -> liftIO $ writeChan (hookModChan rs) (RegisterConnectedHook cb pred)
hookDynamicEvent :: MonadIO m => (DynamicEvent -> XMPPT m Bool) -> (Maybe (DynamicEvent -> Bool)) -> XMPPT m ()
hookConnectedEvent = writeChan hookModificationsChan . RegisterConnectedHook hookDynamicEvent cb pred = ask >>= \rs -> liftIO $ writeChan (hookModChan rs) (RegisterDynamicHook cb pred)
hookDynamicEvent :: Dynamic a => (DynamicEvent a -> XMPPT m Bool) -> XMPPT m () hookStreamsOpenedEvent :: MonadIO m => (OpenedStreamsEvent -> XMPPT m Bool) -> (Maybe (OpenedStreamsEvent -> Bool)) -> XMPPT m ()
hookDynamicEvent h = writeChan hookModificationsChan . RegisterDynamicHook hookStreamsOpenedEvent cb pred = ask >>= \rs -> liftIO $ writeChan (hookModChan rs) (RegisterStreamsOpenedHook cb pred)
hookStreamOpenedEvent :: (StreamOpenedEvent -> XMPPT m Bool) -> XMPPT m () hookTLSSecuredEvent :: MonadIO m => (TLSSecuredEvent -> XMPPT m Bool) -> (Maybe (TLSSecuredEvent -> Bool)) -> XMPPT m ()
hookStreamOpenedEvent = writeChan hookModificationsChan . RegisterStreamOpenedHook hookTLSSecuredEvent cb pred = ask >>= \rs -> liftIO $ writeChan (hookModChan rs) (RegisterTLSSecuredHook cb pred)
hookTLSSecuredEvent :: (TLSSecuredEvent -> XMPPT m Bool) -> XMPPT m () hookAuthenticatedEvent :: MonadIO m => (AuthenticatedEvent -> XMPPT m Bool) -> (Maybe (AuthenticatedEvent -> Bool)) -> XMPPT m ()
hookTLSSecuredEvent = writeChan hookModificationsChan . RegisterTLSSecuredHook hookAuthenticatedEvent cb pred = ask >>= \rs -> liftIO $ writeChan (hookModChan rs) (RegisterAuthenticatedHook cb pred)
hookAuthenticatedEvent :: (AuthenticatedEvent -> XMPPT m Bool) -> XMPPT m () openStreams = openStreams
tlsSecure = tlsSecure
authenticate = authenticate
hookAuthenticatedEvent = writeChan hookModificationsChan . RegisterAuthenticatedHook
fireConnectedEvent = fireConnectedEvent
-- | -- |
-- connect is implemented using hookStreamOpenedEvent, hookTLSSecuredEvent, and -- connect is implemented using hookStreamOpenedEvent, hookTLSSecuredEvent, and
@ -129,35 +168,35 @@ hookAuthenticatedEvent = writeChan hookModificationsChan . RegisterAuthenticated
-- authenticate will not be used by the client. Calling those functions may -- authenticate will not be used by the client. Calling those functions may
-- generate events that can cause connect to behave incorrectly. -- generate events that can cause connect to behave incorrectly.
connect :: HostName -> PortNumber -> Maybe (Maybe [X509], ([X509] -> Bool)) -> Maybe (UserName, Password, Maybe Resource) -> XMPPT m () connect :: MonadIO m => HostName -> PortNumber -> Maybe (Maybe [X509], ([X509] -> Bool)) -> Maybe (UserName, Password, Maybe Resource) -> XMPPT m ()
connect h p Nothing Nothing = do connect h p Nothing Nothing = do
hookStreamOpenedEvent onStreamOpenedEvent Nothing hookStreamsOpenedEvent onStreamsOpenedEvent Nothing
openStream h p openStreams h p
where where
onStreamOpenedEvent Nothing = do onStreamsOpenedEvent Nothing = do
fireConnectedEvent Nothing fireConnectedEvent Nothing
return False return False
onStreamOpenedEvent (Just e) = do onStreamsOpenedEvent (Just e) = do
fireConnectedEvent $ ConnectedFailureReason $ COSFR e fireConnectedEvent $ Left $ COSFR e
return False return False
connect h p (Just t) Nothing = do connect h p (Just t) Nothing = do
hookStreamOpenedEvent onStreamOpenedEvent Nothing hookStreamsOpenedEvent onStreamsOpenedEvent Nothing
openStream h p openStreams h p
where where
onStreamOpenedEvent Nothing = do onStreamsOpenedEvent Nothing = do
hookTLSSecuredEvent onTLSSecuredEvent Nothing hookTLSSecuredEvent onTLSSecuredEvent Nothing
tlsSecure tlsSecure
return False return False
onStreamOpenedEvent (Just e) = do onStreamsOpenedEvent (Just e) = do
fireConnectedEvent $ ConnectedFailureReason $ COSFR e fireConnectedEvent $ Left $ COSFR e
return False return False
onTLSSecuredEvent Nothing = do onTLSSecuredEvent Nothing = do
@ -165,22 +204,22 @@ connect h p (Just t) Nothing = do
return False return False
onTLSSecuredEvent (Just e) = do onTLSSecuredEvent (Just e) = do
fireConnectedEvent $ ConnectedFailureReason $ CTSFR e fireConnectedEvent $ Left $ CTSFR e
return False return False
connect h p Nothing (Just a) = do connect h p Nothing (Just a) = do
hookStreamOpenedEvent onStreamOpenedEvent Nothing hookStreamsOpenedEvent onStreamsOpenedEvent Nothing
openStream h p openStreams h p
where where
onStreamOpenedEvent Nothing = do onStreamsOpenedEvent Nothing = do
hookAuthenticatedEvent onAuthenticatedEvent Nothing hookAuthenticatedEvent onAuthenticatedEvent Nothing
authenticate authenticate
return False return False
onStreamOpenedEvent (Just e) = do onStreamsOpenedEvent (Just e) = do
fireConnectedEvent $ ConnectedFailureReason $ COSFR e fireConnectedEvent $ Left $ COSFR e
return False return False
onAuthenticatedEvent (Right r) = do onAuthenticatedEvent (Right r) = do
@ -188,22 +227,22 @@ connect h p Nothing (Just a) = do
return False return False
onAuthenticated (Left e) = do onAuthenticated (Left e) = do
fireConnectedEvent $ ConnectedFailureReason $ CAFR e fireConnectedEvent $ Left $ CAFR e
return False return False
connect h p (Just t) (Just a) = do connect h p (Just t) (Just a) = do
hookStreamOpenedEvent onStreamOpenedEvent Nothing hookStreamsOpenedEvent onStreamsOpenedEvent Nothing
openStream h p openStreams h p
where where
onStreamOpenedEvent Nothing = do onStreamsOpenedEvent Nothing = do
hookTLSSecuredEvent onTLSSecuredEvent Nothing hookTLSSecuredEvent onTLSSecuredEvent Nothing
tlsSecure tlsSecure
return False return False
onStreamOpenedEvent (Just e) = do onStreamsOpenedEvent (Just e) = do
fireConnectedEvent $ ConnectedFailureReason $ COSFR e fireConnectedEvent $ Left $ COSFR e
return False return False
onTLSSecuredEvent Nothing = do onTLSSecuredEvent Nothing = do
@ -212,7 +251,7 @@ connect h p (Just t) (Just a) = do
return False return False
onTLSSecuredEvent (Just e) = do onTLSSecuredEvent (Just e) = do
fireConnectedEvent $ ConnectedFailureReason $ CTSFR e fireConnectedEvent $ Left $ CTSFR e
return False return False
onAuthenticatedEvent (Right r) = do onAuthenticatedEvent (Right r) = do
@ -220,5 +259,5 @@ connect h p (Just t) (Just a) = do
return False return False
onAuthenticated (Left e) = do onAuthenticated (Left e) = do
fireConnectedEvent $ ConnectedFailureReason $ CAFR e fireConnectedEvent $ Left $ CAFR e
return False return False

16
Network/XMPP/Stream.hs

@ -46,7 +46,7 @@ import qualified Data.Enumerator.List as DEL (head)
-- Reads from the provided handle or TLS context and sends the events to the -- Reads from the provided handle or TLS context and sends the events to the
-- internal event channel. -- internal event channel.
xmlEnumerator :: Chan (InternalEvent s m) -> Either Handle TLSCtx -> IO () xmlEnumerator :: Chan InternalEvent -> Either Handle TLSCtx -> IO () -- Was: InternalEvent s m
xmlEnumerator c s = do xmlEnumerator c s = do
enumeratorResult <- case s of enumeratorResult <- case s of
@ -55,8 +55,8 @@ xmlEnumerator c s = do
Right tlsCtx -> run $ enumTLS tlsCtx $$ joinI $ Right tlsCtx -> run $ enumTLS tlsCtx $$ joinI $
parseBytes decodeEntities $$ eventConsumer c [] 0 parseBytes decodeEntities $$ eventConsumer c [] 0
case enumeratorResult of case enumeratorResult of
Right _ -> writeChan c $ IEE EnumeratorDone Right _ -> return () -- writeChan c $ IEE EnumeratorDone
Left e -> writeChan c $ IEE (EnumeratorException e) Left e -> return () -- writeChan c $ IEE (EnumeratorException e)
where where
-- Behaves like enumHandle, but reads from the TLS context instead -- Behaves like enumHandle, but reads from the TLS context instead
-- TODO: Type? -- TODO: Type?
@ -77,14 +77,14 @@ xmlEnumerator c s = do
-- sends the proper events through the channel. The second parameter should be -- sends the proper events through the channel. The second parameter should be
-- initialized to [] (no events) and the third to 0 (zeroth XML level). -- initialized to [] (no events) and the third to 0 (zeroth XML level).
eventConsumer :: Chan (InternalEvent s m) -> [Event] -> Int -> eventConsumer :: Chan InternalEvent -> [Event] -> Int ->
Iteratee Event IO (Maybe Event) Iteratee Event IO (Maybe Event) -- Was: InternalEvent s m
-- <stream:stream> open event received. -- <stream:stream> open event received.
eventConsumer chan [EventBeginElement (Name localName namespace prefixName) attribs] 0 eventConsumer chan [EventBeginElement (Name localName namespace prefixName) attribs] 0
| localName == pack "stream" && isJust prefixName && fromJust prefixName == pack "stream" = do | localName == pack "stream" && isJust prefixName && fromJust prefixName == pack "stream" = do
liftIO $ writeChan chan $ IEE $ EnumeratorBeginStream from to id ver lang ns liftIO $ return () -- writeChan chan $ IEE $ EnumeratorBeginStream from to id ver lang ns
eventConsumer chan [] 1 eventConsumer chan [] 1
where where
from = case lookup "from" attribs of Nothing -> Nothing; Just fromAttrib -> Just $ show fromAttrib from = case lookup "from" attribs of Nothing -> Nothing; Just fromAttrib -> Just $ show fromAttrib
@ -98,7 +98,7 @@ eventConsumer chan [EventBeginElement (Name localName namespace prefixName) attr
eventConsumer chan [EventEndElement name] 1 eventConsumer chan [EventEndElement name] 1
| namePrefix name == Just (pack "stream") && nameLocalName name == pack "stream" = do | namePrefix name == Just (pack "stream") && nameLocalName name == pack "stream" = do
liftIO $ writeChan chan $ IEE $ EnumeratorEndStream liftIO $ return () -- writeChan chan $ IEE $ EnumeratorEndStream
return Nothing return Nothing
-- Ignore EventDocumentBegin event. -- Ignore EventDocumentBegin event.
@ -109,7 +109,7 @@ eventConsumer chan [EventBeginDocument] 0 = eventConsumer chan [] 0
-- values into an first-level element event. -- values into an first-level element event.
eventConsumer chan ((EventEndElement e):es) 1 = do eventConsumer chan ((EventEndElement e):es) 1 = do
liftIO $ writeChan chan $ IEE $ EnumeratorFirstLevelElement $ eventsToElement $ reverse ((EventEndElement e):es) liftIO $ return () -- writeChan chan $ IEE $ EnumeratorFirstLevelElement $ eventsToElement $ reverse ((EventEndElement e):es)
eventConsumer chan [] 1 eventConsumer chan [] 1
-- Normal condition - accumulate the event. -- Normal condition - accumulate the event.

57
Network/XMPP/Types.hs

@ -442,7 +442,16 @@ data EnumeratorEvent = EnumeratorDone |
-- Type to contain the internal events. -- Type to contain the internal events.
data InternalEvent s m = IEC (ClientEvent s m) | IEE EnumeratorEvent | IET (TimeoutEvent s m) deriving (Show) -- data InternalEvent s m = IEC (ClientEvent s m) | IEE EnumeratorEvent | IET (TimeoutEvent s m) deriving (Show)
-- Internal events processed in the main state loop of Pontarius XMPP. They are
-- either received from the client or from the enumerator.
data InternalEvent
= IECE ClientEvent
| IEEE EnumeratorEvent
data TimeoutEvent s m = TimeoutEvent StanzaID Timeout (StateT s m ()) data TimeoutEvent s m = TimeoutEvent StanzaID Timeout (StateT s m ())
@ -461,27 +470,31 @@ data AuthenticationState = NoAuthentication | AuthenticatingPreChallenge1 String
-- Client actions that needs to be performed in the (main) state loop are -- Client actions that needs to be performed in the (main) state loop are
-- converted to ClientEvents and sent through the internal event channel. -- converted to ClientEvents and sent through the internal event channel.
data ClientEvent s m = CEOpenStream N.HostName PortNumber --data ClientEvent s m = CEOpenStream N.HostName PortNumber
(OpenStreamResult -> StateT s m ()) | -- (OpenStreamResult -> StateT s m ()) |
CESecureWithTLS (Maybe [X509]) ([X509] -> Bool) -- CESecureWithTLS (Maybe [X509]) ([X509] -> Bool)
(SecureWithTLSResult -> StateT s m ()) | -- (SecureWithTLSResult -> StateT s m ()) |
CEAuthenticate UserName Password (Maybe Resource) -- CEAuthenticate UserName Password (Maybe Resource)
(AuthenticateResult -> StateT s m ()) | -- (AuthenticateResult -> StateT s m ()) |
CEMessage Message (Maybe (Message -> StateT s m Bool)) (Maybe (Timeout, StateT s m ())) (Maybe (StreamError -> StateT s m ())) | -- CEMessage Message (Maybe (Message -> StateT s m Bool)) (Maybe (Timeout, StateT s m ())) (Maybe (StreamError -> StateT s m ())) |
CEPresence Presence (Maybe (Presence -> StateT s m Bool)) (Maybe (Timeout, StateT s m ())) (Maybe (StreamError -> StateT s m ())) | -- CEPresence Presence (Maybe (Presence -> StateT s m Bool)) (Maybe (Timeout, StateT s m ())) (Maybe (StreamError -> StateT s m ())) |
CEIQ IQ (Maybe (IQ -> StateT s m Bool)) (Maybe (Timeout, StateT s m ())) (Maybe (StreamError -> StateT s m ())) | -- CEIQ IQ (Maybe (IQ -> StateT s m Bool)) (Maybe (Timeout, StateT s m ())) (Maybe (StreamError -> StateT s m ())) |
CEAction (Maybe (StateT s m Bool)) (StateT s m ()) -- CEAction (Maybe (StateT s m Bool)) (StateT s m ())
instance Show (ClientEvent s m) where
show (CEOpenStream h p _) = "CEOpenStream " ++ h ++ " " ++ (show p) data ClientEvent = ClientEventTest
show (CESecureWithTLS c _ _) = "CESecureWithTLS " ++ (show c)
show (CEAuthenticate u p r _) = "CEAuthenticate " ++ u ++ " " ++ p ++ " " ++
(show r) --instance Show (ClientEvent s m) where
show (CEIQ s _ _ _) = "CEIQ" -- show (CEOpenStream h p _) = "CEOpenStream " ++ h ++ " " ++ (show p)
show (CEMessage s _ _ _) = "CEMessage" -- show (CESecureWithTLS c _ _) = "CESecureWithTLS " ++ (show c)
show (CEPresence s _ _ _) = "CEPresence" -- show (CEAuthenticate u p r _) = "CEAuthenticate " ++ u ++ " " ++ p ++ " " ++
-- (show r)
show (CEAction _ _) = "CEAction" -- show (CEIQ s _ _ _) = "CEIQ"
-- show (CEMessage s _ _ _) = "CEMessage"
-- show (CEPresence s _ _ _) = "CEPresence"
--
-- show (CEAction _ _) = "CEAction"
type StreamID = String type StreamID = String

Loading…
Cancel
Save