From 0ad81874183b0800f44fe7217ff7acbd8ee56c02 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 9 Dec 2012 14:16:19 +0100 Subject: [PATCH] swap names of Context and Session --- examples/EchoClient.hs | 2 +- examples/Example.hs | 2 +- source/Network/Xmpp.hs | 19 +++-------- source/Network/Xmpp/Concurrent.hs | 2 +- source/Network/Xmpp/Concurrent/Channels.hs | 26 +++++++------- .../Network/Xmpp/Concurrent/Channels/Basic.hs | 8 ++--- source/Network/Xmpp/Concurrent/Channels/IQ.hs | 34 +++++++++---------- .../Xmpp/Concurrent/Channels/Message.hs | 16 ++++----- .../Xmpp/Concurrent/Channels/Presence.hs | 10 +++--- .../Network/Xmpp/Concurrent/Channels/Types.hs | 4 +-- source/Network/Xmpp/Concurrent/Monad.hs | 14 ++++---- source/Network/Xmpp/Concurrent/Types.hs | 4 +-- source/Network/Xmpp/Session.hs | 4 +-- source/Network/Xmpp/Xep/ServiceDiscovery.hs | 4 +-- tests/Tests.hs | 10 +++--- 15 files changed, 74 insertions(+), 85 deletions(-) diff --git a/examples/EchoClient.hs b/examples/EchoClient.hs index 6a26e27..0a2f9f3 100644 --- a/examples/EchoClient.hs +++ b/examples/EchoClient.hs @@ -32,7 +32,7 @@ password = "pwd" resource = Just "bot" -- | Automatically accept all subscription requests from other entities -autoAccept :: Context -> IO () +autoAccept :: Session -> IO () autoAccept context = forever $ do st <- waitForPresence isPresenceSubscribe context let Just friend = presenceFrom st diff --git a/examples/Example.hs b/examples/Example.hs index edf6a7a..9f3e8f3 100644 --- a/examples/Example.hs +++ b/examples/Example.hs @@ -42,7 +42,7 @@ main = do singleThreaded $ xmppSASL "pwd" xmppThreadedBind (Just "botsi") -- singleThreaded $ xmppBind (Just "botsi") - singleThreaded $ xmppSession + singleThreaded $ xmppContext forkXmpp autoAccept forkXmpp mirror sendS . SPresence $ Presence Nothing Nothing Nothing Nothing diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 03faca8..0d8400c 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -28,8 +28,8 @@ module Network.Xmpp ( -- * Session management - Context - , newContext + Session + , newSession , withConnection , connectTcp , simpleConnect @@ -40,7 +40,7 @@ module Network.Xmpp , digestMd5 , plain , closeConnection - , endSession + , endContext , setConnectionClosedHandler -- * JID -- | A JID (historically: Jabber ID) is XMPPs native format @@ -144,7 +144,7 @@ module Network.Xmpp , iqRequestPayload , iqResultPayload -- * Threads - , forkContext + , forkSession -- * Miscellaneous , LangTag(..) , exampleParams @@ -165,17 +165,6 @@ import Network.Xmpp.Message import Network.Xmpp.Presence import Network.Xmpp.Sasl import Network.Xmpp.Session --- import Network.Xmpp.Session import Network.Xmpp.Stream import Network.Xmpp.TLS import Network.Xmpp.Types - - --- -- Sends the session IQ set element and waits for an answer. Throws an error if --- -- if an IQ error stanza is returned from the server. --- startSession :: Session -> IO () --- startSession session = do --- answer <- sendIQ' Nothing Set Nothing sessionXML session --- case answer of --- IQResponseResult _ -> return () --- e -> error $ show e diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 4ac42aa..94f0f62 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -1,6 +1,6 @@ {-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Concurrent - ( Session + ( Context , module Network.Xmpp.Concurrent.Monad , module Network.Xmpp.Concurrent.Threads , module Network.Xmpp.Concurrent.Channels diff --git a/source/Network/Xmpp/Concurrent/Channels.hs b/source/Network/Xmpp/Concurrent/Channels.hs index cf89faf..933f168 100644 --- a/source/Network/Xmpp/Concurrent/Channels.hs +++ b/source/Network/Xmpp/Concurrent/Channels.hs @@ -7,7 +7,7 @@ module Network.Xmpp.Concurrent.Channels , module Network.Xmpp.Concurrent.Channels.Presence , module Network.Xmpp.Concurrent.Channels.IQ , toChans - , newContext + , newSession , writeWorker ) @@ -92,8 +92,8 @@ toChans messageC presenceC stanzaC iqHands sta = atomically $ do -- | Creates and initializes a new Xmpp context. -newContext :: Connection -> IO Context -newContext con = do +newSession :: Connection -> IO Session +newSession con = do messageC <- newTChanIO presenceC <- newTChanIO outC <- newTChanIO @@ -110,22 +110,22 @@ newContext con = do curId <- readTVar idRef writeTVar idRef (curId + 1 :: Integer) return . read. show $ curId - let sess = Session { writeRef = wLock + let cont = Context { writeRef = wLock , readerThread = readerThread , idGenerator = getId , conRef = conState , eventHandlers = eh , stopThreads = kill >> killThread writer } - return $ Context { session = sess - , mShadow = messageC - , pShadow = presenceC - , sShadow = stanzaC - , messagesRef = workermCh - , presenceRef = workerpCh - , outCh = outC - , iqHandlers = iqHandlers - } + return $ Session { context = cont + , mShadow = messageC + , pShadow = presenceC + , sShadow = stanzaC + , messagesRef = workermCh + , presenceRef = workerpCh + , outCh = outC + , iqHandlers = iqHandlers + } -- Worker to write stanzas to the stream concurrently. writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO Bool) -> IO () diff --git a/source/Network/Xmpp/Concurrent/Channels/Basic.hs b/source/Network/Xmpp/Concurrent/Channels/Basic.hs index 287b089..cb820fe 100644 --- a/source/Network/Xmpp/Concurrent/Channels/Basic.hs +++ b/source/Network/Xmpp/Concurrent/Channels/Basic.hs @@ -7,16 +7,16 @@ import Network.Xmpp.Concurrent.Channels.Types import Network.Xmpp.Types -- | Get a duplicate of the stanza channel -getStanzaChan :: Context -> IO (TChan Stanza) +getStanzaChan :: Session -> IO (TChan Stanza) getStanzaChan session = atomically $ dupTChan (sShadow session) -- | Send a stanza to the server. -sendStanza :: Stanza -> Context -> IO () +sendStanza :: Stanza -> Session -> IO () sendStanza a session = atomically $ writeTChan (outCh session) a -- | Create a forked session object -forkContext :: Context -> IO Context -forkContext session = do +forkSession :: Session -> IO Session +forkSession session = do mCH' <- newIORef Nothing pCH' <- newIORef Nothing return $ session {messagesRef = mCH' , presenceRef = pCH'} diff --git a/source/Network/Xmpp/Concurrent/Channels/IQ.hs b/source/Network/Xmpp/Concurrent/Channels/IQ.hs index c444296..4c6ce3d 100644 --- a/source/Network/Xmpp/Concurrent/Channels/IQ.hs +++ b/source/Network/Xmpp/Concurrent/Channels/IQ.hs @@ -24,28 +24,28 @@ sendIQ :: Maybe Int -- ^ Timeout -> Maybe LangTag -- ^ Language tag of the payload (@Nothing@ for -- default) -> Element -- ^ The IQ body (there has to be exactly one) - -> Context + -> Session -> IO (TMVar IQResponse) -sendIQ timeOut to tp lang body context = do -- TODO: Add timeout - newId <- idGenerator (session context) +sendIQ timeOut to tp lang body session = do -- TODO: Add timeout + newId <- idGenerator (context session) ref <- atomically $ do resRef <- newEmptyTMVar - (byNS, byId) <- readTVar (iqHandlers context) - writeTVar (iqHandlers context) (byNS, Map.insert newId resRef byId) + (byNS, byId) <- readTVar (iqHandlers session) + writeTVar (iqHandlers session) (byNS, Map.insert newId resRef byId) -- TODO: Check for id collisions (shouldn't happen?) return resRef - sendStanza (IQRequestS $ IQRequest newId Nothing to lang tp body) context + sendStanza (IQRequestS $ IQRequest newId Nothing to lang tp body) session case timeOut of Nothing -> return () Just t -> void . forkIO $ do threadDelay t - doTimeOut (iqHandlers context) newId ref + doTimeOut (iqHandlers session) newId ref return ref where doTimeOut handlers iqid var = atomically $ do p <- tryPutTMVar var IQResponseTimeout when p $ do - (byNS, byId) <- readTVar (iqHandlers context) + (byNS, byId) <- readTVar (iqHandlers session) writeTVar handlers (byNS, Map.delete iqid byId) return () @@ -55,10 +55,10 @@ sendIQ' :: Maybe Jid -> IQRequestType -> Maybe LangTag -> Element - -> Context + -> Session -> IO IQResponse -sendIQ' to tp lang body context = do - ref <- sendIQ (Just 3000000) to tp lang body context +sendIQ' to tp lang body session = do + ref <- sendIQ (Just 3000000) to tp lang body session atomically $ takeTMVar ref @@ -69,10 +69,10 @@ sendIQ' to tp lang body context = do -- to interfere with existing consumers. listenIQChan :: IQRequestType -- ^ Type of IQs to receive (@Get@ or @Set@) -> Text -- ^ Namespace of the child element - -> Context + -> Session -> IO (Either (TChan IQRequestTicket) (TChan IQRequestTicket)) -listenIQChan tp ns context = do - let handlers = (iqHandlers context) +listenIQChan tp ns session = do + let handlers = (iqHandlers session) atomically $ do (byNS, byID) <- readTVar handlers iqCh <- newTChan @@ -88,12 +88,12 @@ listenIQChan tp ns context = do answerIQ :: IQRequestTicket -> Either StanzaError (Maybe Element) - -> Context + -> Session -> IO Bool answerIQ (IQRequestTicket sentRef (IQRequest iqid from _to lang _tp bd)) - answer context = do + answer session = do let response = case answer of Left err -> IQErrorS $ IQError iqid Nothing from lang err (Just bd) Right res -> IQResultS $ IQResult iqid Nothing from lang res @@ -103,6 +103,6 @@ answerIQ (IQRequestTicket False -> do writeTVar sentRef True - writeTChan (outCh context) response + writeTChan (outCh session) response return True True -> return False diff --git a/source/Network/Xmpp/Concurrent/Channels/Message.hs b/source/Network/Xmpp/Concurrent/Channels/Message.hs index aaf71a9..c3619a0 100644 --- a/source/Network/Xmpp/Concurrent/Channels/Message.hs +++ b/source/Network/Xmpp/Concurrent/Channels/Message.hs @@ -11,7 +11,7 @@ import Network.Xmpp.Concurrent.Channels.Basic -- | Get the inbound stanza channel, duplicates from master if necessary. Please -- note that once duplicated it will keep filling up, call 'dropMessageChan' to -- allow it to be garbage collected. -getMessageChan :: Context -> IO (TChan (Either MessageError Message)) +getMessageChan :: Session -> IO (TChan (Either MessageError Message)) getMessageChan session = do mCh <- readIORef . messagesRef $ session case mCh of @@ -23,23 +23,23 @@ getMessageChan session = do -- | Drop the local end of the inbound stanza channel from our context so it can -- be GC-ed. -dropMessageChan :: Context -> IO () +dropMessageChan :: Session -> IO () dropMessageChan session = writeIORef (messagesRef session) Nothing -- | Read an element from the inbound stanza channel, acquiring a copy of the -- channel as necessary. -pullMessage :: Context -> IO (Either MessageError Message) +pullMessage :: Session -> IO (Either MessageError Message) pullMessage session = do c <- getMessageChan session atomically $ readTChan c -- | Get the next received message -getMessage :: Context -> IO Message +getMessage :: Session -> IO Message getMessage = waitForMessage (const True) -- | Pulls a (non-error) message and returns it if the given predicate returns -- @True@. -waitForMessage :: (Message -> Bool) -> Context -> IO Message +waitForMessage :: (Message -> Bool) -> Session -> IO Message waitForMessage f session = do s <- pullMessage session case s of @@ -48,7 +48,7 @@ waitForMessage f session = do | otherwise -> waitForMessage f session -- | Pulls an error message and returns it if the given predicate returns @True@. -waitForMessageError :: (MessageError -> Bool) -> Context -> IO MessageError +waitForMessageError :: (MessageError -> Bool) -> Session -> IO MessageError waitForMessageError f session = do s <- pullMessage session case s of @@ -60,7 +60,7 @@ waitForMessageError f session = do -- | Pulls a message and returns it if the given predicate returns @True@. filterMessages :: (MessageError -> Bool) -> (Message -> Bool) - -> Context -> IO (Either MessageError Message) + -> Session -> IO (Either MessageError Message) filterMessages f g session = do s <- pullMessage session case s of @@ -70,5 +70,5 @@ filterMessages f g session = do | otherwise -> filterMessages f g session -- | Send a message stanza. -sendMessage :: Message -> Context -> IO () +sendMessage :: Message -> Session -> IO () sendMessage m session = sendStanza (MessageS m) session diff --git a/source/Network/Xmpp/Concurrent/Channels/Presence.hs b/source/Network/Xmpp/Concurrent/Channels/Presence.hs index bf93ecb..abcd367 100644 --- a/source/Network/Xmpp/Concurrent/Channels/Presence.hs +++ b/source/Network/Xmpp/Concurrent/Channels/Presence.hs @@ -9,7 +9,7 @@ import Network.Xmpp.Concurrent.Types import Network.Xmpp.Concurrent.Channels.Basic -- | Analogous to 'getMessageChan'. -getPresenceChan :: Context -> IO (TChan (Either PresenceError Presence)) +getPresenceChan :: Session -> IO (TChan (Either PresenceError Presence)) getPresenceChan session = do pCh <- readIORef $ (presenceRef session) case pCh of @@ -21,20 +21,20 @@ getPresenceChan session = do -- | Analogous to 'dropMessageChan'. -dropPresenceChan :: Context -> IO () +dropPresenceChan :: Session -> IO () dropPresenceChan session = writeIORef (presenceRef session) Nothing -- | Read an element from the inbound stanza channel, acquiring a copy of the -- channel as necessary. -pullPresence :: Context -> IO (Either PresenceError Presence) +pullPresence :: Session -> IO (Either PresenceError Presence) pullPresence session = do c <- getPresenceChan session atomically $ readTChan c -- | Pulls a (non-error) presence and returns it if the given predicate returns -- @True@. -waitForPresence :: (Presence -> Bool) -> Context -> IO Presence +waitForPresence :: (Presence -> Bool) -> Session -> IO Presence waitForPresence f session = do s <- pullPresence session case s of @@ -43,5 +43,5 @@ waitForPresence f session = do | otherwise -> waitForPresence f session -- | Send a presence stanza. -sendPresence :: Presence -> Context -> IO () +sendPresence :: Presence -> Session -> IO () sendPresence p session = sendStanza (PresenceS p) session diff --git a/source/Network/Xmpp/Concurrent/Channels/Types.hs b/source/Network/Xmpp/Concurrent/Channels/Types.hs index d02025f..a70e4c2 100644 --- a/source/Network/Xmpp/Concurrent/Channels/Types.hs +++ b/source/Network/Xmpp/Concurrent/Channels/Types.hs @@ -9,8 +9,8 @@ import Network.Xmpp.Concurrent.Types import Network.Xmpp.Types -- | An XMPP session context -data Context = Context - { session :: Session +data Session = Session + { context :: Context -- The original master channels that the reader puts stanzas -- into. These are cloned by @get{STanza,Message,Presence}Chan -- on demand when first used by the thread and are stored in the diff --git a/source/Network/Xmpp/Concurrent/Monad.hs b/source/Network/Xmpp/Concurrent/Monad.hs index a48eb51..070cab3 100644 --- a/source/Network/Xmpp/Concurrent/Monad.hs +++ b/source/Network/Xmpp/Concurrent/Monad.hs @@ -20,7 +20,7 @@ import Network.Xmpp.Connection -- -- temporarily stopped and resumed with the new session details once the action -- -- returns. The action will run in the calling thread. Any uncaught exceptions -- -- will be interpreted as connection failure. --- withConnection :: XmppConMonad a -> Session -> IO (Either StreamError a) +-- withConnection :: XmppConMonad a -> Context -> IO (Either StreamError a) -- withConnection a session = do -- wait <- newEmptyTMVarIO -- Ex.mask_ $ do @@ -59,7 +59,7 @@ import Network.Xmpp.Connection -- ] -- | Executes a function to update the event handlers. -modifyHandlers :: (EventHandlers -> EventHandlers) -> Session -> IO () +modifyHandlers :: (EventHandlers -> EventHandlers) -> Context -> IO () modifyHandlers f session = atomically $ modifyTVar (eventHandlers session) f where -- Borrowing modifyTVar from @@ -71,26 +71,26 @@ modifyHandlers f session = atomically $ modifyTVar (eventHandlers session) f writeTVar var (f x) -- | Sets the handler to be executed when the server connection is closed. -setConnectionClosedHandler :: (StreamError -> Session -> IO ()) -> Session -> IO () +setConnectionClosedHandler :: (StreamError -> Context -> IO ()) -> Context -> IO () setConnectionClosedHandler eh session = do modifyHandlers (\s -> s{connectionClosedHandler = \e -> eh e session}) session -- | Run an event handler. -runHandler :: (EventHandlers -> IO a) -> Session -> IO a +runHandler :: (EventHandlers -> IO a) -> Context -> IO a runHandler h session = h =<< atomically (readTVar $ eventHandlers session) -- | End the current Xmpp session. -endSession :: Session -> IO () -endSession session = do -- TODO: This has to be idempotent (is it?) +endContext :: Context -> IO () +endContext session = do -- TODO: This has to be idempotent (is it?) closeConnection session stopThreads session -- | Close the connection to the server. Closes the stream (by enforcing a -- write lock and sending a element), waits (blocks) for three -- seconds, and then closes the connection. -closeConnection :: Session -> IO () +closeConnection :: Context -> IO () closeConnection session = Ex.mask_ $ do (_send, connection) <- atomically $ liftM2 (,) (takeTMVar $ writeRef session) diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index d71a9d7..962dbd1 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -18,8 +18,8 @@ data EventHandlers = EventHandlers { connectionClosedHandler :: StreamError -> IO () } --- | Xmpp Session object -data Session = Session +-- | Xmpp Context object +data Context = Context { writeRef :: TMVar (BS.ByteString -> IO Bool) , readerThread :: ThreadId , idGenerator :: IO StanzaId diff --git a/source/Network/Xmpp/Session.hs b/source/Network/Xmpp/Session.hs index 70cb2c3..28be338 100644 --- a/source/Network/Xmpp/Session.hs +++ b/source/Network/Xmpp/Session.hs @@ -47,7 +47,7 @@ simpleConnect :: HostName -- ^ Host to connect to -> Text -- ^ Password -> Maybe Text -- ^ Desired resource (or Nothing to let the server -- decide) - -> IO Context + -> IO Session simpleConnect host port hostname username password resource = do con' <- connectTcp host port hostname con <- case con' of @@ -56,7 +56,7 @@ simpleConnect host port hostname username password resource = do startTLS exampleParams con saslResponse <- simpleAuth username password resource con case saslResponse of - Right jid -> newContext con + Right jid -> newSession con Left e -> error $ show e diff --git a/source/Network/Xmpp/Xep/ServiceDiscovery.hs b/source/Network/Xmpp/Xep/ServiceDiscovery.hs index 29fcf83..f4ee1e1 100644 --- a/source/Network/Xmpp/Xep/ServiceDiscovery.hs +++ b/source/Network/Xmpp/Xep/ServiceDiscovery.hs @@ -87,7 +87,7 @@ xpQueryInfo = xpWrap (\(nd, (feats, ids)) -> QIR nd ids feats) -- | Query an entity for it's identity and features queryInfo :: Jid -- ^ Entity to query -> Maybe Text.Text -- ^ Node - -> Context + -> Session -> IO (Either DiscoError QueryInfoResult) queryInfo to node context = do res <- sendIQ' (Just to) Get Nothing queryBody context @@ -151,7 +151,7 @@ xpQueryItems = xpElem (itemsN "query") -- | Query an entity for Items of a node queryItems :: Jid -- ^ Entity to query -> Maybe Text.Text -- ^ Node - -> Context + -> Session -> IO (Either DiscoError (Maybe Text.Text, [Item])) queryItems to node session = do res <- sendIQ' (Just to) Get Nothing queryBody session diff --git a/tests/Tests.hs b/tests/Tests.hs index d9b2db3..48f49e8 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -39,7 +39,7 @@ supervisor = read "uart14@species64739.dyndns.org" testNS :: Text testNS = "xmpp:library:test" -type Xmpp a = Context -> IO a +type Xmpp a = Session -> IO a data Payload = Payload { payloadCounter :: Int @@ -75,7 +75,7 @@ iqResponder context = do answerIQ next (Right $ Just answerBody) context when (payloadCounter payload == 10) $ do threadDelay 1000000 - endSession (session context) + endContext (session context) autoAccept :: Xmpp () autoAccept context = forever $ do @@ -151,7 +151,7 @@ iqTest debug we them context = do debug "ending session" fork action context = do - context' <- forkContext context + context' <- forkSession context forkIO $ action context' ibrTest debug uname pw = IBR.registerWith [ (IBR.Username, "testuser2") @@ -166,11 +166,11 @@ runMain debug number multi = do 0 -> (testUser2, testUser1,False) let debug' = liftIO . atomically . debug . (("Thread " ++ show number ++ ":") ++) - context <- newContext + context <- newSession setConnectionClosedHandler (\e s -> do debug' $ "connection lost because " ++ show e - endSession s) (session context) + endContext s) (session context) debug' "running" flip withConnection (session context) $ Ex.catch (do debug' "connect"