diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 45524e2..0c4ef44 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -37,6 +37,8 @@ module Network.Xmpp , scramSha1 , plain , digestMd5 + , closeConnection + , endSession -- * Addressing -- | A JID (historically: Jabber ID) is XMPPs native format -- for addressing entities in the network. It is somewhat similar to an e-mail @@ -76,7 +78,8 @@ module Network.Xmpp -- presence, or IQ stanza. The particular allowable values for the 'type' -- attribute vary depending on whether the stanza is a message, presence, -- or IQ stanza. - + , getStanza + , getStanzaChan -- ** Messages -- | The /message/ stanza is a /push/ mechanism whereby one entity -- pushes information to another entity, similar to the communications that @@ -163,7 +166,7 @@ module Network.Xmpp , AuthSaslFailure , AuthIllegalCredentials , AuthOtherFailure ) - , SaslHandler(..) + , SaslHandler ) where import Network.Xmpp.Concurrent @@ -171,4 +174,3 @@ import Network.Xmpp.Sasl import Network.Xmpp.Sasl.Types import Network.Xmpp.Stanza import Network.Xmpp.Types -import Network.Xmpp.Utilities diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index c91c1c1..24ced41 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -147,7 +147,9 @@ writeWorker stCh writeR = forever $ do (write, next) <- atomically $ (,) <$> takeTMVar writeR <*> readTChan stCh - r <- write $ renderElement (pickleElem xpStanza next) + let outData = renderElement $ nsHack (pickleElem xpStanza next) + debugOut outData + r <- write outData atomically $ putTMVar writeR write unless r $ do atomically $ unGetTChan stCh next -- If the writing failed, the diff --git a/source/Network/Xmpp/Concurrent/Basic.hs b/source/Network/Xmpp/Concurrent/Basic.hs index 912cba5..99623f9 100644 --- a/source/Network/Xmpp/Concurrent/Basic.hs +++ b/source/Network/Xmpp/Concurrent/Basic.hs @@ -11,6 +11,14 @@ import Control.Monad.State.Strict sendStanza :: Stanza -> Session -> IO () sendStanza a session = atomically $ writeTChan (outCh session) a +-- | Get the channel of incoming stanzas. +getStanzaChan :: Session -> TChan Stanza +getStanzaChan session = stanzaCh session + +-- | Get the next incoming stanza +getStanza :: Session -> IO Stanza +getStanza session = atomically . readTChan $ stanzaCh session + -- | Create a new session object with the inbound channel duplicated dupSession :: Session -> IO Session dupSession session = do diff --git a/source/Network/Xmpp/Concurrent/Monad.hs b/source/Network/Xmpp/Concurrent/Monad.hs index 9a61745..a7e5b19 100644 --- a/source/Network/Xmpp/Concurrent/Monad.hs +++ b/source/Network/Xmpp/Concurrent/Monad.hs @@ -82,8 +82,8 @@ runHandler h session = h =<< atomically (readTVar $ eventHandlers session) -- | End the current Xmpp session. -endContext :: Session -> IO () -endContext session = do -- TODO: This has to be idempotent (is it?) +endSession :: Session -> IO () +endSession session = do -- TODO: This has to be idempotent (is it?) closeConnection session stopThreads session diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs index 5c0b03b..81b3867 100644 --- a/source/Network/Xmpp/Concurrent/Threads.hs +++ b/source/Network/Xmpp/Concurrent/Threads.hs @@ -23,9 +23,10 @@ import System.Log.Logger readWorker :: (Stanza -> IO ()) -> (XmppFailure -> IO ()) -> TMVar Stream - -> IO a -readWorker onStanza onConnectionClosed stateRef = - Ex.mask_ . forever $ do + -> IO () +readWorker onStanza onConnectionClosed stateRef = Ex.mask_ go + where + go = do res <- Ex.catches ( do -- we don't know whether pull will -- necessarily be interruptible @@ -47,10 +48,12 @@ readWorker onStanza onConnectionClosed stateRef = return Nothing ] case res of - Nothing -> return () -- Caught an exception, nothing to do. TODO: Can this happen? - Just (Left _) -> return () - Just (Right sta) -> onStanza sta - where + Nothing -> go -- Caught an exception, nothing to do. TODO: Can this happen? + Just (Left e) -> do + infoM "Pontarius.Xmpp.Reader" $ + "Connection died: " ++ show e + onConnectionClosed e + Just (Right sta) -> onStanza sta >> go -- Defining an Control.Exception.allowInterrupt equivalent for GHC 7 -- compatibility. allowInterrupt :: IO () @@ -78,20 +81,17 @@ startThreadsWith :: (Stanza -> IO ()) TMVar Stream, ThreadId)) startThreadsWith stanzaHandler eh con = do - rd <- withStream' (gets $ streamSend . streamHandle >>= \d -> return $ Right d) con - case rd of - Left e -> return $ Left e - Right read' -> do - writeLock <- newTMVarIO read' - conS <- newTMVarIO con - -- lw <- forkIO $ writeWorker outC writeLock - cp <- forkIO $ connPersist writeLock - rdw <- forkIO $ readWorker stanzaHandler (noCon eh) conS - return $ Right ( killConnection writeLock [rdw, cp] - , writeLock - , conS - , rdw - ) + read' <- withStream' (gets $ streamSend . streamHandle) con + writeLock <- newTMVarIO read' + conS <- newTMVarIO con + -- lw <- forkIO $ writeWorker outC writeLock + cp <- forkIO $ connPersist writeLock + rdw <- forkIO $ readWorker stanzaHandler (noCon eh) conS + return $ Right ( killConnection writeLock [rdw, cp] + , writeLock + , conS + , rdw + ) where killConnection writeLock threads = liftIO $ do _ <- atomically $ takeTMVar writeLock -- Should we put it back? diff --git a/source/Network/Xmpp/IM.hs b/source/Network/Xmpp/IM.hs index 38730e9..2109d30 100644 --- a/source/Network/Xmpp/IM.hs +++ b/source/Network/Xmpp/IM.hs @@ -2,14 +2,17 @@ -- module Network.Xmpp.IM ( -- * Instant Messages - MessageBody(..) + InstantMessage(..) + , MessageBody(..) , MessageThread(..) , MessageSubject(..) , InstantMessage (..) , Subscription(..) , instantMessage + , simpleIM , getIM , withIM + , answerIM -- * Presence , ShowStatus(..) , IMPresence(..) diff --git a/source/Network/Xmpp/IM/Message.hs b/source/Network/Xmpp/IM/Message.hs index 7d5a4b2..f6fdc3a 100644 --- a/source/Network/Xmpp/IM/Message.hs +++ b/source/Network/Xmpp/IM/Message.hs @@ -8,7 +8,6 @@ import Data.XML.Pickle import Data.XML.Types import Network.Xmpp.Marshal import Network.Xmpp.Types -import Network.Xmpp.Stanza import Data.List import Data.Function diff --git a/source/Network/Xmpp/IM/Presence.hs b/source/Network/Xmpp/IM/Presence.hs index dbfc4f5..d5d3750 100644 --- a/source/Network/Xmpp/IM/Presence.hs +++ b/source/Network/Xmpp/IM/Presence.hs @@ -30,7 +30,7 @@ instance Read ShowStatus where data IMPresence = IMP { showStatus :: Maybe ShowStatus , status :: Maybe Text , priority :: Maybe Int - } + } deriving Show imPresence :: IMPresence imPresence = IMP { showStatus = Nothing diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs index dad82d4..8bfe098 100644 --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -65,7 +65,7 @@ xpPresence = ("xpPresence" , "") xpWrap (xpAttrImplied "from" xpPrim) (xpAttrImplied "to" xpPrim) xpLangTag - (xpAttr "type" $ xpWithDefault Available xpPrim) + (xpDefault Available $ xpAttr "type" xpPrim) ) (xpAll xpElemVerbatim) ) diff --git a/source/Network/Xmpp/Stanza.hs b/source/Network/Xmpp/Stanza.hs index aee5582..c5cc124 100644 --- a/source/Network/Xmpp/Stanza.hs +++ b/source/Network/Xmpp/Stanza.hs @@ -10,27 +10,6 @@ module Network.Xmpp.Stanza where import Data.XML.Types import Network.Xmpp.Types - --- | An empty message -message :: Message -message = Message { messageID = Nothing - , messageFrom = Nothing - , messageTo = Nothing - , messageLangTag = Nothing - , messageType = Normal - , messagePayload = [] - } - --- | An empty presence. -presence :: Presence -presence = Presence { presenceID = Nothing - , presenceFrom = Nothing - , presenceTo = Nothing - , presenceLangTag = Nothing - , presenceType = Available - , presencePayload = [] - } - -- | Request subscription with an entity. presenceSubscribe :: Jid -> Presence presenceSubscribe to = presence { presenceTo = Just to diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index b760483..6bc9832 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -142,9 +142,7 @@ startStream = runErrorT $ do ) response <- ErrorT $ runEventsSink $ runErrorT $ streamS expectedTo case response of - Left e -> throwError e - -- Successful unpickling of stream element. - Right (Right (ver, from, to, sid, lt, features)) + Right (ver, from, to, sid, lt, features) | (Text.unpack ver) /= "1.0" -> closeStreamWithError StreamUnsupportedVersion Nothing "Unknown version" @@ -174,7 +172,7 @@ startStream = runErrorT $ do } ) return () -- Unpickling failed - we investigate the element. - Right (Left (Element name attrs _children)) + Left (Element name attrs _children) | (nameLocalName name /= "stream") -> closeStreamWithError StreamInvalidXml Nothing "Root element is not stream" @@ -236,11 +234,11 @@ flattenAttrs attrs = Prelude.map (\(name, cont) -> -- and calls xmppStartStream. restartStream :: StateT StreamState IO (Either XmppFailure ()) restartStream = do - lift $ debugM "Pontarius.XMPP" "Restarting stream..." + liftIO $ debugM "Pontarius.XMPP" "Restarting stream..." raw <- gets (streamReceive . streamHandle) - let newSource = DCI.ResumableSource (loopRead raw $= XP.parseBytes def) - (return ()) - modify (\s -> s{streamEventSource = newSource }) + let newSource =loopRead raw $= XP.parseBytes def + buffered <- liftIO . bufferSrc $ newSource + modify (\s -> s{streamEventSource = buffered }) startStream where loopRead rd = do @@ -253,6 +251,29 @@ restartStream = do yield bs loopRead rd +-- We buffer sources because we don't want to lose data when multiple +-- xml-entities are sent with the same packet and we don't want to eternally +-- block the StreamState while waiting for data to arrive +bufferSrc :: MonadIO m => Source IO o -> IO (ConduitM i o m ()) +bufferSrc src = do + ref <- newTMVarIO $ DCI.ResumableSource src (return ()) + let go = do + dt <- liftIO $ Ex.bracketOnError (atomically $ takeTMVar ref) + (\_ -> atomically . putTMVar ref $ + DCI.ResumableSource zeroSource + (return ()) + ) + (\s -> do + (s', dt) <- s $$++ CL.head + atomically $ putTMVar ref s' + return dt + ) + case dt of + Nothing -> return () + Just d -> yield d >> go + return go + + -- Reads the (partial) stream:stream and the server features from the stream. -- Returns the (unvalidated) stream attributes, the unparsed element, or -- throwError throws a `XmppOtherFailure' (if something other than an element @@ -353,14 +374,18 @@ pushElement x = do -- HACK: We remove the "jabber:client" namespace because it is set as -- default in the stream. This is to make isode's M-LINK server happy and -- should be removed once jabber.org accepts prefix-free canonicalization - nsHack e@(Element{elementName = n}) - | nameNamespace n == Just "jabber:client" = - e{ elementName = Name (nameLocalName n) Nothing Nothing - , elementNodes = map mapNSHack $ elementNodes e - } - | otherwise = e - mapNSHack (NodeElement e) = NodeElement $ nsHack e - mapNSHack n = n + +nsHack :: Element -> Element +nsHack e@(Element{elementName = n}) + | nameNamespace n == Just "jabber:client" = + e{ elementName = Name (nameLocalName n) Nothing Nothing + , elementNodes = map mapNSHack $ elementNodes e + } + | otherwise = e + where + mapNSHack :: Node -> Node + mapNSHack (NodeElement el) = NodeElement $ nsHack el + mapNSHack nd = nd -- | Encode and send stanza pushStanza :: Stanza -> Stream -> IO (Either XmppFailure Bool) @@ -384,23 +409,21 @@ pushOpenElement e = do -- `Connect-and-resumes' the given sink to the stream source, and pulls a -- `b' value. -runEventsSink :: Sink Event IO b -> StateT StreamState IO (Either XmppFailure b) +runEventsSink :: Sink Event IO b -> StateT StreamState IO b runEventsSink snk = do -- TODO: Wrap exceptions? src <- gets streamEventSource - (src', r) <- lift $ src $$++ snk - modify (\s -> s{streamEventSource = src'}) - return $ Right r + r <- liftIO $ src $$ snk + return r pullElement :: StateT StreamState IO (Either XmppFailure Element) pullElement = do ExL.catches (do e <- runEventsSink (elements =$ await) case e of - Left f -> return $ Left f - Right Nothing -> do - lift $ errorM "Pontarius.XMPP" "pullElement: No element." + Nothing -> do + lift $ errorM "Pontarius.XMPP" "pullElement: Stream ended." return . Left $ XmppOtherFailure - Right (Just r) -> return $ Right r + Just r -> return $ Right r ) [ ExL.Handler (\StreamEnd -> return $ Left StreamEndFailure) , ExL.Handler (\(InvalidXmppXml s) -- Invalid XML `Event' encountered, or missing element close tag @@ -429,7 +452,7 @@ pullUnpickle p = do -- | Pulls a stanza (or stream error) from the stream. pullStanza :: Stream -> IO (Either XmppFailure Stanza) -pullStanza = withStream $ do +pullStanza = withStream' $ do res <- pullUnpickle xpStreamStanza case res of Left e -> return $ Left e @@ -459,7 +482,7 @@ xmppNoStream = StreamState { , streamFlush = return () , streamClose = return () } - , streamEventSource = DCI.ResumableSource zeroSource (return ()) + , streamEventSource = zeroSource , streamFeatures = StreamFeatures Nothing [] [] , streamAddress = Nothing , streamFrom = Nothing @@ -468,11 +491,11 @@ xmppNoStream = StreamState { , streamJid = Nothing , streamConfiguration = def } - where - zeroSource :: Source IO output - zeroSource = liftIO $ do - errorM "Pontarius.Xmpp" "zeroSource utilized." - ExL.throwIO XmppOtherFailure + +zeroSource :: Source IO output +zeroSource = liftIO $ do + errorM "Pontarius.Xmpp" "zeroSource" + ExL.throwIO XmppOtherFailure createStream :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (Stream) createStream realm config = do @@ -482,9 +505,9 @@ createStream realm config = do debugM "Pontarius.Xmpp" "Acquired handle." debugM "Pontarius.Xmpp" "Setting NoBuffering mode on handle." hSetBuffering h NoBuffering - let eSource = DCI.ResumableSource - ((sourceHandle h $= logConduit) $= XP.parseBytes def) - (return ()) + eSource <- liftIO . bufferSrc $ + (sourceHandle h $= logConduit) $= XP.parseBytes def + let hand = StreamHandle { streamSend = \d -> catchPush $ BS.hPut h d , streamReceive = \n -> BS.hGetSome h n , streamFlush = hFlush h @@ -791,5 +814,5 @@ withStream' action (Stream stream) = do return r -mkStream :: StreamState -> IO (Stream) -mkStream con = Stream `fmap` (atomically $ newTMVar con) +mkStream :: StreamState -> IO Stream +mkStream con = Stream `fmap` atomically (newTMVar con) diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs index f9f1745..f3b8a4e 100644 --- a/source/Network/Xmpp/Tls.hs +++ b/source/Network/Xmpp/Tls.hs @@ -122,7 +122,7 @@ tlsinit params backend = do handshake con let src = forever $ do dt <- liftIO $ recvData con - liftIO $ debugM "Pontarius.Xmpp.TLS" ("in :" ++ BSC8.unpack dt) + liftIO $ debugM "Pontarius.Xmpp.TLS" ("In :" ++ BSC8.unpack dt) yield dt let snk = do d <- await @@ -134,6 +134,7 @@ tlsinit params backend = do readWithBuffer <- liftIO $ mkReadBuffer (recvData con) return ( src , snk + -- Note: sendData already sends the data to the debug output , \s -> sendData con $ BL.fromChunks [s] , liftIO . readWithBuffer , con diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 99b7108..d93bb70 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -15,9 +15,11 @@ module Network.Xmpp.Types , IdGenerator(..) , LangTag (..) , Message(..) + , message , MessageError(..) , MessageType(..) , Presence(..) + , presence , PresenceError(..) , PresenceType(..) , SaslError(..) @@ -155,6 +157,21 @@ data Message = Message { messageID :: !(Maybe StanzaID) , messagePayload :: ![Element] } deriving Show + + +-- | An empty message +message :: Message +message = Message { messageID = Nothing + , messageFrom = Nothing + , messageTo = Nothing + , messageLangTag = Nothing + , messageType = Normal + , messagePayload = [] + } + +instance Default Message where + def = message + -- | An error stanza generated in response to a 'Message'. data MessageError = MessageError { messageErrorID :: !(Maybe StanzaID) , messageErrorFrom :: !(Maybe Jid) @@ -224,6 +241,18 @@ data Presence = Presence { presenceID :: !(Maybe StanzaID) , presencePayload :: ![Element] } deriving Show +-- | An empty presence. +presence :: Presence +presence = Presence { presenceID = Nothing + , presenceFrom = Nothing + , presenceTo = Nothing + , presenceLangTag = Nothing + , presenceType = Available + , presencePayload = [] + } + +instance Default Presence where + def = presence -- | An error stanza generated in response to a 'Presence'. data PresenceError = PresenceError { presenceErrorID :: !(Maybe StanzaID) @@ -795,7 +824,7 @@ data StreamState = StreamState -- | Functions to send, receive, flush, and close on the stream , streamHandle :: StreamHandle -- | Event conduit source, and its associated finalizer - , streamEventSource :: ResumableSource IO Event + , streamEventSource :: Source IO Event -- | Stream features advertised by the server , streamFeatures :: !StreamFeatures -- TODO: Maybe? -- | The hostname or IP specified for the connection diff --git a/source/Network/Xmpp/Utilities.hs b/source/Network/Xmpp/Utilities.hs index 6d4cee3..87d9a91 100644 --- a/source/Network/Xmpp/Utilities.hs +++ b/source/Network/Xmpp/Utilities.hs @@ -8,10 +8,14 @@ module Network.Xmpp.Utilities , renderOpenElement , renderElement , checkHostName + , withTMVar ) where import Control.Applicative ((<|>)) +import Control.Concurrent.STM +import Control.Exception +import Control.Monad.State.Strict import qualified Data.Attoparsec.Text as AP import qualified Data.ByteString as BS import Data.Conduit as C @@ -25,6 +29,17 @@ import System.IO.Unsafe(unsafePerformIO) import qualified Text.XML.Stream.Render as TXSR import Text.XML.Unresolved as TXU +-- | Apply f with the content of tv as state, restoring the original value when an +-- exception occurs +withTMVar :: TMVar a -> (a -> IO (c, a)) -> IO c +withTMVar tv f = bracketOnError (atomically $ takeTMVar tv) + (atomically . putTMVar tv) + (\s -> do + (x, s') <- f s + atomically $ putTMVar tv s' + return x + ) + openElementToEvents :: Element -> [Event] openElementToEvents (Element name as ns) = EventBeginElement name as : goN ns [] where diff --git a/tests/Tests.hs b/tests/Tests.hs index 48f49e8..ba7dadb 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PackageImports, OverloadedStrings, NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction #-} module Example where import Control.Concurrent @@ -17,24 +17,27 @@ import Data.XML.Types import Network import Network.Xmpp -import Network.Xmpp.Concurrent.Channels import Network.Xmpp.IM.Presence -import Network.Xmpp.Pickle +import Network.Xmpp.Internal +import Network.Xmpp.Marshal import Network.Xmpp.Types -import qualified Network.Xmpp.Xep.InbandRegistration as IBR +-- import qualified Network.Xmpp.Xep.InbandRegistration as IBR +import Data.Default (def) import qualified Network.Xmpp.Xep.ServiceDiscovery as Disco - import System.Environment -import Text.XML.Stream.Elements +import System.Log.Logger testUser1 :: Jid -testUser1 = read "testuser1@species64739.dyndns.org/bot1" +testUser1 = "echo1@species64739.dyndns.org/bot" testUser2 :: Jid -testUser2 = read "testuser2@species64739.dyndns.org/bot2" +testUser2 = "echo2@species64739.dyndns.org/bot" supervisor :: Jid -supervisor = read "uart14@species64739.dyndns.org" +supervisor = "uart14@species64739.dyndns.org" + +config = def{sessionStreamConfiguration + = def{connectionDetails = UseHost "localhost" (PortNumber 5222)}} testNS :: Text testNS = "xmpp:library:test" @@ -60,7 +63,7 @@ payloadP = xpWrap (\((counter,flag) , message) -> Payload counter flag message) invertPayload (Payload count flag message) = Payload (count + 1) (not flag) (Text.reverse message) iqResponder context = do - chan' <- listenIQChan Get testNS context + chan' <- listenIQChan Set testNS context chan <- case chan' of Left _ -> liftIO $ putStrLn "Channel was already taken" >> error "hanging up" @@ -72,15 +75,18 @@ iqResponder context = do let answerPayload = invertPayload payload let answerBody = pickleElem payloadP answerPayload unless (payloadCounter payload == 3) . void $ - answerIQ next (Right $ Just answerBody) context - when (payloadCounter payload == 10) $ do - threadDelay 1000000 - endContext (session context) + answerIQ next (Right $ Just answerBody) + autoAccept :: Xmpp () autoAccept context = forever $ do - st <- waitForPresence isPresenceSubscribe context - sendPresence (presenceSubscribed (fromJust $ presenceFrom st)) context + st <- waitForPresence (\p -> presenceType p == Subscribe) context + sendPresence (presenceSubscribed (fromJust $ presenceFrom st)) context + +showPresence context = forever $ do + pr <- waitForPresence (const True) context + print $ getIMPresence pr + simpleMessage :: Jid -> Text -> Message simpleMessage to txt = message @@ -111,23 +117,23 @@ expect debug x y context | x == y = debug "Ok." wait3 :: MonadIO m => m () wait3 = liftIO $ threadDelay 1000000 -discoTest debug context = do - q <- Disco.queryInfo "species64739.dyndns.org" Nothing context - case q of - Left (Disco.DiscoXMLError el e) -> do - debug (ppElement el) - debug (Text.unpack $ ppUnpickleError e) - debug (show $ length $ elementNodes el) - x -> debug $ show x - - q <- Disco.queryItems "species64739.dyndns.org" - (Just "http://jabber.org/protocol/commands") context - case q of - Left (Disco.DiscoXMLError el e) -> do - debug (ppElement el) - debug (Text.unpack $ ppUnpickleError e) - debug (show $ length $ elementNodes el) - x -> debug $ show x +-- discoTest debug context = do +-- q <- Disco.queryInfo "species64739.dyndns.org" Nothing context +-- case q of +-- Left (Disco.DiscoXMLError el e) -> do +-- debug (ppElement el) +-- debug (Text.unpack $ ppUnpickleError e) +-- debug (show $ length $ elementNodes el) +-- x -> debug $ show x + +-- q <- Disco.queryItems "species64739.dyndns.org" +-- (Just "http://jabber.org/protocol/commands") context +-- case q of +-- Left (Disco.DiscoXMLError el e) -> do +-- debug (ppElement el) +-- debug (Text.unpack $ ppUnpickleError e) +-- debug (show $ length $ elementNodes el) +-- x -> debug $ show x iqTest debug we them context = do forM [1..10] $ \count -> do @@ -135,7 +141,7 @@ iqTest debug we them context = do let payload = Payload count (even count) (Text.pack $ show count) let body = pickleElem payloadP payload debug "sending" - answer <- sendIQ' (Just them) Get Nothing body context + answer <- sendIQ' (Just them) Set Nothing body context case answer of IQResponseResult r -> do debug "received" @@ -147,16 +153,12 @@ iqTest debug we them context = do IQResponseError e -> do debug $ "Error in packet: " ++ show count liftIO $ threadDelay 100000 - sendUser "All tests done" context +-- sendUser "All tests done" context debug "ending session" -fork action context = do - context' <- forkSession context - forkIO $ action context' - -ibrTest debug uname pw = IBR.registerWith [ (IBR.Username, "testuser2") - , (IBR.Password, "pwd") - ] >>= debug . show +-- ibrTest debug uname pw = IBR.registerWith [ (IBR.Username, "testuser2") +-- , (IBR.Password, "pwd") +-- ] >>= debug . show runMain :: (String -> STM ()) -> Int -> Bool -> IO () @@ -166,50 +168,23 @@ runMain debug number multi = do 0 -> (testUser2, testUser1,False) let debug' = liftIO . atomically . debug . (("Thread " ++ show number ++ ":") ++) - context <- newSession - - setConnectionClosedHandler (\e s -> do - debug' $ "connection lost because " ++ show e - endContext s) (session context) debug' "running" - flip withConnection (session context) $ Ex.catch (do - debug' "connect" - connect "localhost" (PortNumber 5222) "species64739.dyndns.org" --- debug' "tls start" - startTLS exampleParams - debug' "ibr start" - -- ibrTest debug' (localpart we) "pwd" - -- debug' "ibr end" - saslResponse <- simpleAuth - (fromJust $ localpart we) "pwd" (resourcepart we) - case saslResponse of - Right _ -> return () - Left e -> error $ show e - debug' "session standing" - features <- other `liftM` gets sFeatures - liftIO . void $ forM features $ \f -> debug' $ ppElement f - ) - (\e -> debug' $ show (e ::Ex.SomeException)) + Right context <- session (Text.unpack $ domainpart we) + (Just ([scramSha1 (fromJust $ localpart we) Nothing "pwd"], resourcepart we)) + config sendPresence presenceOnline context - thread1 <- fork autoAccept context - sendPresence (presenceSubscribe them) context - thread2 <- fork iqResponder context + thread1 <- forkIO $ autoAccept =<< dupSession context + thread2 <- forkIO $ iqResponder =<< dupSession context + thread2 <- forkIO $ showPresence =<< dupSession context when active $ do liftIO $ threadDelay 1000000 -- Wait for the other thread to go online -- discoTest debug' - when multi $ iqTest debug' we them context - closeConnection (session context) +-- when multi $ iqTest debug' we them context killThread thread1 killThread thread2 return () liftIO . threadDelay $ 10^6 -- unless multi . void . withConnection $ IBR.unregister - unless multi . void $ fork (\s -> forever $ do - pullMessage s >>= debug' . show - putStrLn "" - putStrLn "" - ) - context liftIO . forever $ threadDelay 1000000 return () @@ -221,4 +196,6 @@ run i multi = do runMain debugOut (2 + i) multi -main = run 0 True +main = do + updateGlobalLogger "Pontarius.Xmpp" $ setLevel DEBUG + run 0 True