Browse Source

swap names of Context and Session

master
Philipp Balzarek 13 years ago
parent
commit
0ad8187418
  1. 2
      examples/EchoClient.hs
  2. 2
      examples/Example.hs
  3. 19
      source/Network/Xmpp.hs
  4. 2
      source/Network/Xmpp/Concurrent.hs
  5. 10
      source/Network/Xmpp/Concurrent/Channels.hs
  6. 8
      source/Network/Xmpp/Concurrent/Channels/Basic.hs
  7. 34
      source/Network/Xmpp/Concurrent/Channels/IQ.hs
  8. 16
      source/Network/Xmpp/Concurrent/Channels/Message.hs
  9. 10
      source/Network/Xmpp/Concurrent/Channels/Presence.hs
  10. 4
      source/Network/Xmpp/Concurrent/Channels/Types.hs
  11. 14
      source/Network/Xmpp/Concurrent/Monad.hs
  12. 4
      source/Network/Xmpp/Concurrent/Types.hs
  13. 4
      source/Network/Xmpp/Session.hs
  14. 4
      source/Network/Xmpp/Xep/ServiceDiscovery.hs
  15. 10
      tests/Tests.hs

2
examples/EchoClient.hs

@ -32,7 +32,7 @@ password = "pwd"
resource = Just "bot" resource = Just "bot"
-- | Automatically accept all subscription requests from other entities -- | Automatically accept all subscription requests from other entities
autoAccept :: Context -> IO () autoAccept :: Session -> IO ()
autoAccept context = forever $ do autoAccept context = forever $ do
st <- waitForPresence isPresenceSubscribe context st <- waitForPresence isPresenceSubscribe context
let Just friend = presenceFrom st let Just friend = presenceFrom st

2
examples/Example.hs

@ -42,7 +42,7 @@ main = do
singleThreaded $ xmppSASL "pwd" singleThreaded $ xmppSASL "pwd"
xmppThreadedBind (Just "botsi") xmppThreadedBind (Just "botsi")
-- singleThreaded $ xmppBind (Just "botsi") -- singleThreaded $ xmppBind (Just "botsi")
singleThreaded $ xmppSession singleThreaded $ xmppContext
forkXmpp autoAccept forkXmpp autoAccept
forkXmpp mirror forkXmpp mirror
sendS . SPresence $ Presence Nothing Nothing Nothing Nothing sendS . SPresence $ Presence Nothing Nothing Nothing Nothing

19
source/Network/Xmpp.hs

@ -28,8 +28,8 @@
module Network.Xmpp module Network.Xmpp
( -- * Session management ( -- * Session management
Context Session
, newContext , newSession
, withConnection , withConnection
, connectTcp , connectTcp
, simpleConnect , simpleConnect
@ -40,7 +40,7 @@ module Network.Xmpp
, digestMd5 , digestMd5
, plain , plain
, closeConnection , closeConnection
, endSession , endContext
, setConnectionClosedHandler , setConnectionClosedHandler
-- * JID -- * JID
-- | A JID (historically: Jabber ID) is XMPPs native format -- | A JID (historically: Jabber ID) is XMPPs native format
@ -144,7 +144,7 @@ module Network.Xmpp
, iqRequestPayload , iqRequestPayload
, iqResultPayload , iqResultPayload
-- * Threads -- * Threads
, forkContext , forkSession
-- * Miscellaneous -- * Miscellaneous
, LangTag(..) , LangTag(..)
, exampleParams , exampleParams
@ -165,17 +165,6 @@ import Network.Xmpp.Message
import Network.Xmpp.Presence import Network.Xmpp.Presence
import Network.Xmpp.Sasl import Network.Xmpp.Sasl
import Network.Xmpp.Session import Network.Xmpp.Session
-- import Network.Xmpp.Session
import Network.Xmpp.Stream import Network.Xmpp.Stream
import Network.Xmpp.TLS import Network.Xmpp.TLS
import Network.Xmpp.Types 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

2
source/Network/Xmpp/Concurrent.hs

@ -1,6 +1,6 @@
{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_HADDOCK hide #-}
module Network.Xmpp.Concurrent module Network.Xmpp.Concurrent
( Session ( Context
, module Network.Xmpp.Concurrent.Monad , module Network.Xmpp.Concurrent.Monad
, module Network.Xmpp.Concurrent.Threads , module Network.Xmpp.Concurrent.Threads
, module Network.Xmpp.Concurrent.Channels , module Network.Xmpp.Concurrent.Channels

10
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.Presence
, module Network.Xmpp.Concurrent.Channels.IQ , module Network.Xmpp.Concurrent.Channels.IQ
, toChans , toChans
, newContext , newSession
, writeWorker , writeWorker
) )
@ -92,8 +92,8 @@ toChans messageC presenceC stanzaC iqHands sta = atomically $ do
-- | Creates and initializes a new Xmpp context. -- | Creates and initializes a new Xmpp context.
newContext :: Connection -> IO Context newSession :: Connection -> IO Session
newContext con = do newSession con = do
messageC <- newTChanIO messageC <- newTChanIO
presenceC <- newTChanIO presenceC <- newTChanIO
outC <- newTChanIO outC <- newTChanIO
@ -110,14 +110,14 @@ newContext con = do
curId <- readTVar idRef curId <- readTVar idRef
writeTVar idRef (curId + 1 :: Integer) writeTVar idRef (curId + 1 :: Integer)
return . read. show $ curId return . read. show $ curId
let sess = Session { writeRef = wLock let cont = Context { writeRef = wLock
, readerThread = readerThread , readerThread = readerThread
, idGenerator = getId , idGenerator = getId
, conRef = conState , conRef = conState
, eventHandlers = eh , eventHandlers = eh
, stopThreads = kill >> killThread writer , stopThreads = kill >> killThread writer
} }
return $ Context { session = sess return $ Session { context = cont
, mShadow = messageC , mShadow = messageC
, pShadow = presenceC , pShadow = presenceC
, sShadow = stanzaC , sShadow = stanzaC

8
source/Network/Xmpp/Concurrent/Channels/Basic.hs

@ -7,16 +7,16 @@ import Network.Xmpp.Concurrent.Channels.Types
import Network.Xmpp.Types import Network.Xmpp.Types
-- | Get a duplicate of the stanza channel -- | Get a duplicate of the stanza channel
getStanzaChan :: Context -> IO (TChan Stanza) getStanzaChan :: Session -> IO (TChan Stanza)
getStanzaChan session = atomically $ dupTChan (sShadow session) getStanzaChan session = atomically $ dupTChan (sShadow session)
-- | Send a stanza to the server. -- | Send a stanza to the server.
sendStanza :: Stanza -> Context -> IO () sendStanza :: Stanza -> Session -> IO ()
sendStanza a session = atomically $ writeTChan (outCh session) a sendStanza a session = atomically $ writeTChan (outCh session) a
-- | Create a forked session object -- | Create a forked session object
forkContext :: Context -> IO Context forkSession :: Session -> IO Session
forkContext session = do forkSession session = do
mCH' <- newIORef Nothing mCH' <- newIORef Nothing
pCH' <- newIORef Nothing pCH' <- newIORef Nothing
return $ session {messagesRef = mCH' , presenceRef = pCH'} return $ session {messagesRef = mCH' , presenceRef = pCH'}

34
source/Network/Xmpp/Concurrent/Channels/IQ.hs

@ -24,28 +24,28 @@ sendIQ :: Maybe Int -- ^ Timeout
-> Maybe LangTag -- ^ Language tag of the payload (@Nothing@ for -> Maybe LangTag -- ^ Language tag of the payload (@Nothing@ for
-- default) -- default)
-> Element -- ^ The IQ body (there has to be exactly one) -> Element -- ^ The IQ body (there has to be exactly one)
-> Context -> Session
-> IO (TMVar IQResponse) -> IO (TMVar IQResponse)
sendIQ timeOut to tp lang body context = do -- TODO: Add timeout sendIQ timeOut to tp lang body session = do -- TODO: Add timeout
newId <- idGenerator (session context) newId <- idGenerator (context session)
ref <- atomically $ do ref <- atomically $ do
resRef <- newEmptyTMVar resRef <- newEmptyTMVar
(byNS, byId) <- readTVar (iqHandlers context) (byNS, byId) <- readTVar (iqHandlers session)
writeTVar (iqHandlers context) (byNS, Map.insert newId resRef byId) writeTVar (iqHandlers session) (byNS, Map.insert newId resRef byId)
-- TODO: Check for id collisions (shouldn't happen?) -- TODO: Check for id collisions (shouldn't happen?)
return resRef 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 case timeOut of
Nothing -> return () Nothing -> return ()
Just t -> void . forkIO $ do Just t -> void . forkIO $ do
threadDelay t threadDelay t
doTimeOut (iqHandlers context) newId ref doTimeOut (iqHandlers session) newId ref
return ref return ref
where where
doTimeOut handlers iqid var = atomically $ do doTimeOut handlers iqid var = atomically $ do
p <- tryPutTMVar var IQResponseTimeout p <- tryPutTMVar var IQResponseTimeout
when p $ do when p $ do
(byNS, byId) <- readTVar (iqHandlers context) (byNS, byId) <- readTVar (iqHandlers session)
writeTVar handlers (byNS, Map.delete iqid byId) writeTVar handlers (byNS, Map.delete iqid byId)
return () return ()
@ -55,10 +55,10 @@ sendIQ' :: Maybe Jid
-> IQRequestType -> IQRequestType
-> Maybe LangTag -> Maybe LangTag
-> Element -> Element
-> Context -> Session
-> IO IQResponse -> IO IQResponse
sendIQ' to tp lang body context = do sendIQ' to tp lang body session = do
ref <- sendIQ (Just 3000000) to tp lang body context ref <- sendIQ (Just 3000000) to tp lang body session
atomically $ takeTMVar ref atomically $ takeTMVar ref
@ -69,10 +69,10 @@ sendIQ' to tp lang body context = do
-- to interfere with existing consumers. -- to interfere with existing consumers.
listenIQChan :: IQRequestType -- ^ Type of IQs to receive (@Get@ or @Set@) listenIQChan :: IQRequestType -- ^ Type of IQs to receive (@Get@ or @Set@)
-> Text -- ^ Namespace of the child element -> Text -- ^ Namespace of the child element
-> Context -> Session
-> IO (Either (TChan IQRequestTicket) (TChan IQRequestTicket)) -> IO (Either (TChan IQRequestTicket) (TChan IQRequestTicket))
listenIQChan tp ns context = do listenIQChan tp ns session = do
let handlers = (iqHandlers context) let handlers = (iqHandlers session)
atomically $ do atomically $ do
(byNS, byID) <- readTVar handlers (byNS, byID) <- readTVar handlers
iqCh <- newTChan iqCh <- newTChan
@ -88,12 +88,12 @@ listenIQChan tp ns context = do
answerIQ :: IQRequestTicket answerIQ :: IQRequestTicket
-> Either StanzaError (Maybe Element) -> Either StanzaError (Maybe Element)
-> Context -> Session
-> IO Bool -> IO Bool
answerIQ (IQRequestTicket answerIQ (IQRequestTicket
sentRef sentRef
(IQRequest iqid from _to lang _tp bd)) (IQRequest iqid from _to lang _tp bd))
answer context = do answer session = do
let response = case answer of let response = case answer of
Left err -> IQErrorS $ IQError iqid Nothing from lang err (Just bd) Left err -> IQErrorS $ IQError iqid Nothing from lang err (Just bd)
Right res -> IQResultS $ IQResult iqid Nothing from lang res Right res -> IQResultS $ IQResult iqid Nothing from lang res
@ -103,6 +103,6 @@ answerIQ (IQRequestTicket
False -> do False -> do
writeTVar sentRef True writeTVar sentRef True
writeTChan (outCh context) response writeTChan (outCh session) response
return True return True
True -> return False True -> return False

16
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 -- | Get the inbound stanza channel, duplicates from master if necessary. Please
-- note that once duplicated it will keep filling up, call 'dropMessageChan' to -- note that once duplicated it will keep filling up, call 'dropMessageChan' to
-- allow it to be garbage collected. -- allow it to be garbage collected.
getMessageChan :: Context -> IO (TChan (Either MessageError Message)) getMessageChan :: Session -> IO (TChan (Either MessageError Message))
getMessageChan session = do getMessageChan session = do
mCh <- readIORef . messagesRef $ session mCh <- readIORef . messagesRef $ session
case mCh of 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 -- | Drop the local end of the inbound stanza channel from our context so it can
-- be GC-ed. -- be GC-ed.
dropMessageChan :: Context -> IO () dropMessageChan :: Session -> IO ()
dropMessageChan session = writeIORef (messagesRef session) Nothing dropMessageChan session = writeIORef (messagesRef session) Nothing
-- | Read an element from the inbound stanza channel, acquiring a copy of the -- | Read an element from the inbound stanza channel, acquiring a copy of the
-- channel as necessary. -- channel as necessary.
pullMessage :: Context -> IO (Either MessageError Message) pullMessage :: Session -> IO (Either MessageError Message)
pullMessage session = do pullMessage session = do
c <- getMessageChan session c <- getMessageChan session
atomically $ readTChan c atomically $ readTChan c
-- | Get the next received message -- | Get the next received message
getMessage :: Context -> IO Message getMessage :: Session -> IO Message
getMessage = waitForMessage (const True) getMessage = waitForMessage (const True)
-- | Pulls a (non-error) message and returns it if the given predicate returns -- | Pulls a (non-error) message and returns it if the given predicate returns
-- @True@. -- @True@.
waitForMessage :: (Message -> Bool) -> Context -> IO Message waitForMessage :: (Message -> Bool) -> Session -> IO Message
waitForMessage f session = do waitForMessage f session = do
s <- pullMessage session s <- pullMessage session
case s of case s of
@ -48,7 +48,7 @@ waitForMessage f session = do
| otherwise -> waitForMessage f session | otherwise -> waitForMessage f session
-- | Pulls an error message and returns it if the given predicate returns @True@. -- | 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 waitForMessageError f session = do
s <- pullMessage session s <- pullMessage session
case s of case s of
@ -60,7 +60,7 @@ waitForMessageError f session = do
-- | Pulls a message and returns it if the given predicate returns @True@. -- | Pulls a message and returns it if the given predicate returns @True@.
filterMessages :: (MessageError -> Bool) filterMessages :: (MessageError -> Bool)
-> (Message -> Bool) -> (Message -> Bool)
-> Context -> IO (Either MessageError Message) -> Session -> IO (Either MessageError Message)
filterMessages f g session = do filterMessages f g session = do
s <- pullMessage session s <- pullMessage session
case s of case s of
@ -70,5 +70,5 @@ filterMessages f g session = do
| otherwise -> filterMessages f g session | otherwise -> filterMessages f g session
-- | Send a message stanza. -- | Send a message stanza.
sendMessage :: Message -> Context -> IO () sendMessage :: Message -> Session -> IO ()
sendMessage m session = sendStanza (MessageS m) session sendMessage m session = sendStanza (MessageS m) session

10
source/Network/Xmpp/Concurrent/Channels/Presence.hs

@ -9,7 +9,7 @@ import Network.Xmpp.Concurrent.Types
import Network.Xmpp.Concurrent.Channels.Basic import Network.Xmpp.Concurrent.Channels.Basic
-- | Analogous to 'getMessageChan'. -- | Analogous to 'getMessageChan'.
getPresenceChan :: Context -> IO (TChan (Either PresenceError Presence)) getPresenceChan :: Session -> IO (TChan (Either PresenceError Presence))
getPresenceChan session = do getPresenceChan session = do
pCh <- readIORef $ (presenceRef session) pCh <- readIORef $ (presenceRef session)
case pCh of case pCh of
@ -21,20 +21,20 @@ getPresenceChan session = do
-- | Analogous to 'dropMessageChan'. -- | Analogous to 'dropMessageChan'.
dropPresenceChan :: Context -> IO () dropPresenceChan :: Session -> IO ()
dropPresenceChan session = writeIORef (presenceRef session) Nothing dropPresenceChan session = writeIORef (presenceRef session) Nothing
-- | Read an element from the inbound stanza channel, acquiring a copy of the -- | Read an element from the inbound stanza channel, acquiring a copy of the
-- channel as necessary. -- channel as necessary.
pullPresence :: Context -> IO (Either PresenceError Presence) pullPresence :: Session -> IO (Either PresenceError Presence)
pullPresence session = do pullPresence session = do
c <- getPresenceChan session c <- getPresenceChan session
atomically $ readTChan c atomically $ readTChan c
-- | Pulls a (non-error) presence and returns it if the given predicate returns -- | Pulls a (non-error) presence and returns it if the given predicate returns
-- @True@. -- @True@.
waitForPresence :: (Presence -> Bool) -> Context -> IO Presence waitForPresence :: (Presence -> Bool) -> Session -> IO Presence
waitForPresence f session = do waitForPresence f session = do
s <- pullPresence session s <- pullPresence session
case s of case s of
@ -43,5 +43,5 @@ waitForPresence f session = do
| otherwise -> waitForPresence f session | otherwise -> waitForPresence f session
-- | Send a presence stanza. -- | Send a presence stanza.
sendPresence :: Presence -> Context -> IO () sendPresence :: Presence -> Session -> IO ()
sendPresence p session = sendStanza (PresenceS p) session sendPresence p session = sendStanza (PresenceS p) session

4
source/Network/Xmpp/Concurrent/Channels/Types.hs

@ -9,8 +9,8 @@ import Network.Xmpp.Concurrent.Types
import Network.Xmpp.Types import Network.Xmpp.Types
-- | An XMPP session context -- | An XMPP session context
data Context = Context data Session = Session
{ session :: Session { context :: Context
-- The original master channels that the reader puts stanzas -- The original master channels that the reader puts stanzas
-- into. These are cloned by @get{STanza,Message,Presence}Chan -- into. These are cloned by @get{STanza,Message,Presence}Chan
-- on demand when first used by the thread and are stored in the -- on demand when first used by the thread and are stored in the

14
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 -- -- temporarily stopped and resumed with the new session details once the action
-- -- returns. The action will run in the calling thread. Any uncaught exceptions -- -- returns. The action will run in the calling thread. Any uncaught exceptions
-- -- will be interpreted as connection failure. -- -- 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 -- withConnection a session = do
-- wait <- newEmptyTMVarIO -- wait <- newEmptyTMVarIO
-- Ex.mask_ $ do -- Ex.mask_ $ do
@ -59,7 +59,7 @@ import Network.Xmpp.Connection
-- ] -- ]
-- | Executes a function to update the event handlers. -- | 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 modifyHandlers f session = atomically $ modifyTVar (eventHandlers session) f
where where
-- Borrowing modifyTVar from -- Borrowing modifyTVar from
@ -71,26 +71,26 @@ modifyHandlers f session = atomically $ modifyTVar (eventHandlers session) f
writeTVar var (f x) writeTVar var (f x)
-- | Sets the handler to be executed when the server connection is closed. -- | 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 setConnectionClosedHandler eh session = do
modifyHandlers (\s -> s{connectionClosedHandler = modifyHandlers (\s -> s{connectionClosedHandler =
\e -> eh e session}) session \e -> eh e session}) session
-- | Run an event handler. -- | 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) runHandler h session = h =<< atomically (readTVar $ eventHandlers session)
-- | End the current Xmpp session. -- | End the current Xmpp session.
endSession :: Session -> IO () endContext :: Context -> IO ()
endSession session = do -- TODO: This has to be idempotent (is it?) endContext session = do -- TODO: This has to be idempotent (is it?)
closeConnection session closeConnection session
stopThreads session stopThreads session
-- | Close the connection to the server. Closes the stream (by enforcing a -- | Close the connection to the server. Closes the stream (by enforcing a
-- write lock and sending a </stream:stream> element), waits (blocks) for three -- write lock and sending a </stream:stream> element), waits (blocks) for three
-- seconds, and then closes the connection. -- seconds, and then closes the connection.
closeConnection :: Session -> IO () closeConnection :: Context -> IO ()
closeConnection session = Ex.mask_ $ do closeConnection session = Ex.mask_ $ do
(_send, connection) <- atomically $ liftM2 (,) (_send, connection) <- atomically $ liftM2 (,)
(takeTMVar $ writeRef session) (takeTMVar $ writeRef session)

4
source/Network/Xmpp/Concurrent/Types.hs

@ -18,8 +18,8 @@ data EventHandlers = EventHandlers
{ connectionClosedHandler :: StreamError -> IO () { connectionClosedHandler :: StreamError -> IO ()
} }
-- | Xmpp Session object -- | Xmpp Context object
data Session = Session data Context = Context
{ writeRef :: TMVar (BS.ByteString -> IO Bool) { writeRef :: TMVar (BS.ByteString -> IO Bool)
, readerThread :: ThreadId , readerThread :: ThreadId
, idGenerator :: IO StanzaId , idGenerator :: IO StanzaId

4
source/Network/Xmpp/Session.hs

@ -47,7 +47,7 @@ simpleConnect :: HostName -- ^ Host to connect to
-> Text -- ^ Password -> Text -- ^ Password
-> Maybe Text -- ^ Desired resource (or Nothing to let the server -> Maybe Text -- ^ Desired resource (or Nothing to let the server
-- decide) -- decide)
-> IO Context -> IO Session
simpleConnect host port hostname username password resource = do simpleConnect host port hostname username password resource = do
con' <- connectTcp host port hostname con' <- connectTcp host port hostname
con <- case con' of con <- case con' of
@ -56,7 +56,7 @@ simpleConnect host port hostname username password resource = do
startTLS exampleParams con startTLS exampleParams con
saslResponse <- simpleAuth username password resource con saslResponse <- simpleAuth username password resource con
case saslResponse of case saslResponse of
Right jid -> newContext con Right jid -> newSession con
Left e -> error $ show e Left e -> error $ show e

4
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 -- | Query an entity for it's identity and features
queryInfo :: Jid -- ^ Entity to query queryInfo :: Jid -- ^ Entity to query
-> Maybe Text.Text -- ^ Node -> Maybe Text.Text -- ^ Node
-> Context -> Session
-> IO (Either DiscoError QueryInfoResult) -> IO (Either DiscoError QueryInfoResult)
queryInfo to node context = do queryInfo to node context = do
res <- sendIQ' (Just to) Get Nothing queryBody context res <- sendIQ' (Just to) Get Nothing queryBody context
@ -151,7 +151,7 @@ xpQueryItems = xpElem (itemsN "query")
-- | Query an entity for Items of a node -- | Query an entity for Items of a node
queryItems :: Jid -- ^ Entity to query queryItems :: Jid -- ^ Entity to query
-> Maybe Text.Text -- ^ Node -> Maybe Text.Text -- ^ Node
-> Context -> Session
-> IO (Either DiscoError (Maybe Text.Text, [Item])) -> IO (Either DiscoError (Maybe Text.Text, [Item]))
queryItems to node session = do queryItems to node session = do
res <- sendIQ' (Just to) Get Nothing queryBody session res <- sendIQ' (Just to) Get Nothing queryBody session

10
tests/Tests.hs

@ -39,7 +39,7 @@ supervisor = read "uart14@species64739.dyndns.org"
testNS :: Text testNS :: Text
testNS = "xmpp:library:test" testNS = "xmpp:library:test"
type Xmpp a = Context -> IO a type Xmpp a = Session -> IO a
data Payload = Payload data Payload = Payload
{ payloadCounter :: Int { payloadCounter :: Int
@ -75,7 +75,7 @@ iqResponder context = do
answerIQ next (Right $ Just answerBody) context answerIQ next (Right $ Just answerBody) context
when (payloadCounter payload == 10) $ do when (payloadCounter payload == 10) $ do
threadDelay 1000000 threadDelay 1000000
endSession (session context) endContext (session context)
autoAccept :: Xmpp () autoAccept :: Xmpp ()
autoAccept context = forever $ do autoAccept context = forever $ do
@ -151,7 +151,7 @@ iqTest debug we them context = do
debug "ending session" debug "ending session"
fork action context = do fork action context = do
context' <- forkContext context context' <- forkSession context
forkIO $ action context' forkIO $ action context'
ibrTest debug uname pw = IBR.registerWith [ (IBR.Username, "testuser2") ibrTest debug uname pw = IBR.registerWith [ (IBR.Username, "testuser2")
@ -166,11 +166,11 @@ runMain debug number multi = do
0 -> (testUser2, testUser1,False) 0 -> (testUser2, testUser1,False)
let debug' = liftIO . atomically . let debug' = liftIO . atomically .
debug . (("Thread " ++ show number ++ ":") ++) debug . (("Thread " ++ show number ++ ":") ++)
context <- newContext context <- newSession
setConnectionClosedHandler (\e s -> do setConnectionClosedHandler (\e s -> do
debug' $ "connection lost because " ++ show e debug' $ "connection lost because " ++ show e
endSession s) (session context) endContext s) (session context)
debug' "running" debug' "running"
flip withConnection (session context) $ Ex.catch (do flip withConnection (session context) $ Ex.catch (do
debug' "connect" debug' "connect"

Loading…
Cancel
Save