diff --git a/Network/XMPP.hs b/Network/XMPP.hs index d7707bb..9e81293 100644 --- a/Network/XMPP.hs +++ b/Network/XMPP.hs @@ -35,27 +35,27 @@ module Network.XMPP ( -- Network.XMPP.JID , fromStrings -- Network.XMPP.Session - , ClientHandler (..) - , ClientState (..) - , ConnectResult (..) - , HostName - , Password - , PortNumber - , Resource - , Session - , TerminationReason - , UserName - , sendIQ - , sendPresence - , sendMessage - , connect - , openStreams - , tlsSecureStreams - , authenticate - , session - , OpenStreamResult (..) - , SecureWithTLSResult (..) - , AuthenticateResult (..) + -- , ClientHandler (..) + -- , ClientState (..) + -- , ConnectResult (..) + -- , HostName + -- , Password + -- , PortNumber + -- , Resource + -- , Session + -- , TerminationReason + -- , UserName + -- , sendIQ + -- , sendPresence + -- , sendMessage + -- , connect + -- , openStreams + -- , tlsSecureStreams + -- , authenticate + -- , session + -- , OpenStreamResult (..) + -- , SecureWithTLSResult (..) + -- , AuthenticateResult (..) -- Network.XMPP.Stanza , StanzaID (SID) @@ -68,9 +68,7 @@ module Network.XMPP ( -- Network.XMPP.JID , Presence (..) , IQ (..) , iqPayloadNamespace - , iqPayload - - , injectAction ) where + , iqPayload ) where import Network.XMPP.Address import Network.XMPP.SASL diff --git a/Network/XMPP/Session.hs b/Network/XMPP/Session.hs index cd973a1..98617b9 100644 --- a/Network/XMPP/Session.hs +++ b/Network/XMPP/Session.hs @@ -4,57 +4,82 @@ -- TODO: Predicates on callbacks? -- 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) ) 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 -- context. -data XMPPT m a = XMPPT { runXMPPT :: XMPPT m a -> m a - , internalEventChan :: Chan InternalEvent - , hookModificationsChan :: Chan HookModification } +newtype XMPPT m a + = XMPPT { runXMPPT :: ReaderT (ReaderState m) m a } + 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. -data Event - = 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 ConnectedEvent = ConnectedEvent (Either ConnectedFailureReason Resource) +-- data DynamicEvent = forall a. Dynamic a => DynamicEvent a +data DynamicEvent = DynamicEvent Dynamic -data ConnectedFailureReason - = COSFR -- OpenStreamFailureReason - | CTSFR -- TLSSecureFailureReason - | CAFR -- AuthenticateFailureReason +type OpenedStreamsEvent = Maybe OpenStreamsFailureReason +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 --- either received from the client or from the enumerator. +data OpenStreamsFailureReason = OpenStreamFailureReason -data InternalEvent - = IECE ClientEvent - | IEEE EnumeratorEvent +data TLSSecureFailureReason = TLSSecureFailureReason + +data AuthenticateFailureReason = AuthenticateFailureReason -- 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. data HookModification m - = RegisterConnectedHook (ConnectedEvent -> XMPPT m Bool) - | forall a. Dynamic a => RegisterDynamicHook (DynamicEvent a -> XMPPT m Bool) + = 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 State = State stateLoop :: State -> Chan InternalEvent -> IO () @@ -85,30 +117,37 @@ processInternalEvent s ie = (s, [connectIO]) 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 @@ -129,35 +168,35 @@ hookAuthenticatedEvent = writeChan hookModificationsChan . RegisterAuthenticated -- authenticate will not be used by the client. Calling those functions may -- 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 - hookStreamOpenedEvent onStreamOpenedEvent Nothing - openStream h p + hookStreamsOpenedEvent onStreamsOpenedEvent Nothing + openStreams h p where - onStreamOpenedEvent Nothing = do + onStreamsOpenedEvent Nothing = do fireConnectedEvent Nothing return False - onStreamOpenedEvent (Just e) = do - fireConnectedEvent $ ConnectedFailureReason $ COSFR e + onStreamsOpenedEvent (Just e) = do + fireConnectedEvent $ Left $ COSFR e return False connect h p (Just t) Nothing = do - hookStreamOpenedEvent onStreamOpenedEvent Nothing - openStream h p + hookStreamsOpenedEvent onStreamsOpenedEvent Nothing + openStreams h p where - onStreamOpenedEvent Nothing = do + onStreamsOpenedEvent Nothing = do hookTLSSecuredEvent onTLSSecuredEvent Nothing tlsSecure return False - onStreamOpenedEvent (Just e) = do - fireConnectedEvent $ ConnectedFailureReason $ COSFR e + onStreamsOpenedEvent (Just e) = do + fireConnectedEvent $ Left $ COSFR e return False onTLSSecuredEvent Nothing = do @@ -165,22 +204,22 @@ connect h p (Just t) Nothing = do return False onTLSSecuredEvent (Just e) = do - fireConnectedEvent $ ConnectedFailureReason $ CTSFR e + fireConnectedEvent $ Left $ CTSFR e return False connect h p Nothing (Just a) = do - hookStreamOpenedEvent onStreamOpenedEvent Nothing - openStream h p + hookStreamsOpenedEvent onStreamsOpenedEvent Nothing + openStreams h p where - onStreamOpenedEvent Nothing = do + onStreamsOpenedEvent Nothing = do hookAuthenticatedEvent onAuthenticatedEvent Nothing authenticate return False - onStreamOpenedEvent (Just e) = do - fireConnectedEvent $ ConnectedFailureReason $ COSFR e + onStreamsOpenedEvent (Just e) = do + fireConnectedEvent $ Left $ COSFR e return False onAuthenticatedEvent (Right r) = do @@ -188,22 +227,22 @@ connect h p Nothing (Just a) = do return False onAuthenticated (Left e) = do - fireConnectedEvent $ ConnectedFailureReason $ CAFR e + fireConnectedEvent $ Left $ CAFR e return False connect h p (Just t) (Just a) = do - hookStreamOpenedEvent onStreamOpenedEvent Nothing - openStream h p + hookStreamsOpenedEvent onStreamsOpenedEvent Nothing + openStreams h p where - onStreamOpenedEvent Nothing = do + onStreamsOpenedEvent Nothing = do hookTLSSecuredEvent onTLSSecuredEvent Nothing tlsSecure return False - onStreamOpenedEvent (Just e) = do - fireConnectedEvent $ ConnectedFailureReason $ COSFR e + onStreamsOpenedEvent (Just e) = do + fireConnectedEvent $ Left $ COSFR e return False onTLSSecuredEvent Nothing = do @@ -212,7 +251,7 @@ connect h p (Just t) (Just a) = do return False onTLSSecuredEvent (Just e) = do - fireConnectedEvent $ ConnectedFailureReason $ CTSFR e + fireConnectedEvent $ Left $ CTSFR e return False onAuthenticatedEvent (Right r) = do @@ -220,5 +259,5 @@ connect h p (Just t) (Just a) = do return False onAuthenticated (Left e) = do - fireConnectedEvent $ ConnectedFailureReason $ CAFR e + fireConnectedEvent $ Left $ CAFR e return False diff --git a/Network/XMPP/Stream.hs b/Network/XMPP/Stream.hs index 2ceac79..15cd082 100644 --- a/Network/XMPP/Stream.hs +++ b/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 -- 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 enumeratorResult <- case s of @@ -55,8 +55,8 @@ xmlEnumerator c s = do Right tlsCtx -> run $ enumTLS tlsCtx $$ joinI $ parseBytes decodeEntities $$ eventConsumer c [] 0 case enumeratorResult of - Right _ -> writeChan c $ IEE EnumeratorDone - Left e -> writeChan c $ IEE (EnumeratorException e) + Right _ -> return () -- writeChan c $ IEE EnumeratorDone + Left e -> return () -- writeChan c $ IEE (EnumeratorException e) where -- Behaves like enumHandle, but reads from the TLS context instead -- TODO: Type? @@ -77,14 +77,14 @@ xmlEnumerator c s = do -- sends the proper events through the channel. The second parameter should be -- initialized to [] (no events) and the third to 0 (zeroth XML level). -eventConsumer :: Chan (InternalEvent s m) -> [Event] -> Int -> - Iteratee Event IO (Maybe Event) +eventConsumer :: Chan InternalEvent -> [Event] -> Int -> + Iteratee Event IO (Maybe Event) -- Was: InternalEvent s m -- open event received. eventConsumer chan [EventBeginElement (Name localName namespace prefixName) attribs] 0 | 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 where 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 | namePrefix name == Just (pack "stream") && nameLocalName name == pack "stream" = do - liftIO $ writeChan chan $ IEE $ EnumeratorEndStream + liftIO $ return () -- writeChan chan $ IEE $ EnumeratorEndStream return Nothing -- Ignore EventDocumentBegin event. @@ -109,7 +109,7 @@ eventConsumer chan [EventBeginDocument] 0 = eventConsumer chan [] 0 -- values into an first-level element event. 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 -- Normal condition - accumulate the event. diff --git a/Network/XMPP/Types.hs b/Network/XMPP/Types.hs index b656333..d69553e 100644 --- a/Network/XMPP/Types.hs +++ b/Network/XMPP/Types.hs @@ -442,7 +442,16 @@ data EnumeratorEvent = EnumeratorDone | -- 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 ()) @@ -461,27 +470,31 @@ data AuthenticationState = NoAuthentication | AuthenticatingPreChallenge1 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 N.HostName PortNumber - (OpenStreamResult -> StateT s m ()) | - CESecureWithTLS (Maybe [X509]) ([X509] -> Bool) - (SecureWithTLSResult -> StateT s m ()) | - CEAuthenticate UserName Password (Maybe Resource) - (AuthenticateResult -> 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 ())) | - 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 ()) - -instance Show (ClientEvent s m) where - show (CEOpenStream h p _) = "CEOpenStream " ++ h ++ " " ++ (show p) - show (CESecureWithTLS c _ _) = "CESecureWithTLS " ++ (show c) - show (CEAuthenticate u p r _) = "CEAuthenticate " ++ u ++ " " ++ p ++ " " ++ - (show r) - show (CEIQ s _ _ _) = "CEIQ" - show (CEMessage s _ _ _) = "CEMessage" - show (CEPresence s _ _ _) = "CEPresence" - - show (CEAction _ _) = "CEAction" +--data ClientEvent s m = CEOpenStream N.HostName PortNumber +-- (OpenStreamResult -> StateT s m ()) | +-- CESecureWithTLS (Maybe [X509]) ([X509] -> Bool) +-- (SecureWithTLSResult -> StateT s m ()) | +-- CEAuthenticate UserName Password (Maybe Resource) +-- (AuthenticateResult -> 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 ())) | +-- 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 ()) + + +data ClientEvent = ClientEventTest + + +--instance Show (ClientEvent s m) where +-- show (CEOpenStream h p _) = "CEOpenStream " ++ h ++ " " ++ (show p) +-- show (CESecureWithTLS c _ _) = "CESecureWithTLS " ++ (show c) +-- show (CEAuthenticate u p r _) = "CEAuthenticate " ++ u ++ " " ++ p ++ " " ++ +-- (show r) +-- show (CEIQ s _ _ _) = "CEIQ" +-- show (CEMessage s _ _ _) = "CEMessage" +-- show (CEPresence s _ _ _) = "CEPresence" +-- +-- show (CEAction _ _) = "CEAction" type StreamID = String