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

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

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

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
 
 -- <stream:stream> 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.

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