From 1f3a18f2eff2f22d7ff41c7252431c817e70b40d Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 6 May 2013 14:49:42 +0200 Subject: [PATCH 01/11] change pullStanza to not block the stream add debugging information for outgoing stanzas over TLS cleanup in Xmpp.Concurrent.Threads --- source/Network/Xmpp/Concurrent/Threads.hs | 25 ++++++++++------------- source/Network/Xmpp/Stream.hs | 2 +- source/Network/Xmpp/Tls.hs | 4 +++- 3 files changed, 15 insertions(+), 16 deletions(-) diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs index 5c0b03b..7a73a09 100644 --- a/source/Network/Xmpp/Concurrent/Threads.hs +++ b/source/Network/Xmpp/Concurrent/Threads.hs @@ -78,20 +78,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/Stream.hs b/source/Network/Xmpp/Stream.hs index b760483..bbd5790 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -429,7 +429,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 diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs index f9f1745..75ea5dc 100644 --- a/source/Network/Xmpp/Tls.hs +++ b/source/Network/Xmpp/Tls.hs @@ -134,7 +134,9 @@ tlsinit params backend = do readWithBuffer <- liftIO $ mkReadBuffer (recvData con) return ( src , snk - , \s -> sendData con $ BL.fromChunks [s] + , \s -> do + liftIO $ debugM "Pontarius.Xmpp.TLS" ("out :" ++ BSC8.unpack s) + sendData con $ BL.fromChunks [s] , liftIO . readWithBuffer , con ) From f69d5ca7dffc75287219f25b3915085a29076a78 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 7 May 2013 12:08:39 +0200 Subject: [PATCH 02/11] export InstantMessage, simpleIM and answerIM --- source/Network/Xmpp/IM.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/source/Network/Xmpp/IM.hs b/source/Network/Xmpp/IM.hs index 2f5bf08..41eadb8 100644 --- a/source/Network/Xmpp/IM.hs +++ b/source/Network/Xmpp/IM.hs @@ -2,12 +2,15 @@ -- module Network.Xmpp.IM ( -- * Instant Messages - MessageBody(..) + InstantMessage(..) + , MessageBody(..) , MessageThread(..) , MessageSubject(..) , instantMessage + , simpleIM , getIM , withIM + , answerIM -- * Presence , ShowStatus(..) , IMPresence(..) From 8211794a30e72e0430338d65f77ac10200b21f27 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 12 May 2013 14:30:59 +0200 Subject: [PATCH 03/11] Use the name space hack in the writer thread --- source/Network/Xmpp/Concurrent.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) 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 From 3fd8859e2df289737f5cb15ef3cadd11bce6be69 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 12 May 2013 14:57:25 +0200 Subject: [PATCH 04/11] fix debug messages in Network.Xmpp.TLS --- source/Network/Xmpp/Tls.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs index 75ea5dc..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,9 +134,8 @@ tlsinit params backend = do readWithBuffer <- liftIO $ mkReadBuffer (recvData con) return ( src , snk - , \s -> do - liftIO $ debugM "Pontarius.Xmpp.TLS" ("out :" ++ BSC8.unpack s) - sendData con $ BL.fromChunks [s] + -- Note: sendData already sends the data to the debug output + , \s -> sendData con $ BL.fromChunks [s] , liftIO . readWithBuffer , con ) From 008398e75fea3b107a87eaa3c69e86a2654cf48c Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 12 May 2013 17:03:56 +0200 Subject: [PATCH 05/11] export nsHack from Network.Xmpp.Stream --- source/Network/Xmpp/Stream.hs | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index bbd5790..88a9e81 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -353,14 +353,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) From a130d611f48731d12e7301668f5f93b8ed82763e Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 19 May 2013 12:14:20 +0200 Subject: [PATCH 06/11] add getStanza and getStanzaChan --- source/Network/Xmpp.hs | 4 ++-- source/Network/Xmpp/Concurrent/Basic.hs | 8 ++++++++ 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index bc8281b..b693d56 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -76,7 +76,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 @@ -169,4 +170,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/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 From a7ac1e59e2dd851664084d1bee06c1e5cb4c1420 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 19 May 2013 12:18:46 +0200 Subject: [PATCH 07/11] change reader conduit to buffered source kill reader thread when end of stream is reached --- source/Network/Xmpp/Concurrent/Threads.hs | 17 +-- source/Network/Xmpp/Stream.hs | 73 ++++++++----- source/Network/Xmpp/Types.hs | 2 +- source/Network/Xmpp/Utilities.hs | 15 +++ tests/Tests.hs | 120 +++++++++------------- 5 files changed, 118 insertions(+), 109 deletions(-) diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs index 7a73a09..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 () diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 88a9e81..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 @@ -388,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 @@ -463,7 +482,7 @@ xmppNoStream = StreamState { , streamFlush = return () , streamClose = return () } - , streamEventSource = DCI.ResumableSource zeroSource (return ()) + , streamEventSource = zeroSource , streamFeatures = StreamFeatures Nothing [] [] , streamAddress = Nothing , streamFrom = Nothing @@ -472,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 @@ -486,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 @@ -795,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/Types.hs b/source/Network/Xmpp/Types.hs index 6720061..4d9e097 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -794,7 +794,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..f9f5867 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,14 +75,12 @@ 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 + st <- waitForPresence (\p -> presenceType p == Just Subscribe) context sendPresence (presenceSubscribed (fromJust $ presenceFrom st)) context simpleMessage :: Jid -> Text -> Message @@ -111,23 +112,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 +136,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 +148,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 +163,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 + thread1 <- forkIO $ autoAccept =<< dupSession context sendPresence (presenceSubscribe them) context - thread2 <- fork iqResponder context + thread2 <- forkIO $ iqResponder =<< 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) 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 +191,6 @@ run i multi = do runMain debugOut (2 + i) multi -main = run 0 True +main = do + updateGlobalLogger "Pontarius.Xmpp" $ setLevel DEBUG + run 0 True From a03df77a0453c638ca4253c7621b3fa635160b8d Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 19 May 2013 13:23:33 +0200 Subject: [PATCH 08/11] fix xpPresence --- source/Network/Xmpp/Marshal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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) ) From c01fe109999c2fa6e8f455ea651f4f71133a472c Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 19 May 2013 13:24:31 +0200 Subject: [PATCH 09/11] add cleseConnection and endSession --- source/Network/Xmpp.hs | 4 +++- source/Network/Xmpp/Concurrent/Monad.hs | 4 ++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index c57c632..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 @@ -164,7 +166,7 @@ module Network.Xmpp , AuthSaslFailure , AuthIllegalCredentials , AuthOtherFailure ) - , SaslHandler(..) + , SaslHandler ) where import Network.Xmpp.Concurrent 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 From 96b6e5b6e983d09c154a0dd4d44a2916b9cc4ce0 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 19 May 2013 13:27:31 +0200 Subject: [PATCH 10/11] derive Show for IMPresence --- source/Network/Xmpp/IM/Presence.hs | 2 +- tests/Tests.hs | 13 +++++++++---- 2 files changed, 10 insertions(+), 5 deletions(-) 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/tests/Tests.hs b/tests/Tests.hs index f9f5867..ba7dadb 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -80,8 +80,13 @@ iqResponder context = do autoAccept :: Xmpp () autoAccept context = forever $ do - st <- waitForPresence (\p -> presenceType p == Just Subscribe) 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 @@ -169,12 +174,12 @@ runMain debug number multi = do config sendPresence presenceOnline context thread1 <- forkIO $ autoAccept =<< dupSession context - sendPresence (presenceSubscribe them) 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 +-- when multi $ iqTest debug' we them context killThread thread1 killThread thread2 return () From a2bab5852596f53ecece56f186c77e8825ae2160 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 19 May 2013 13:45:01 +0200 Subject: [PATCH 11/11] add Default instance for Message and Presence --- source/Network/Xmpp/IM/Message.hs | 1 - source/Network/Xmpp/Stanza.hs | 21 --------------------- source/Network/Xmpp/Types.hs | 29 +++++++++++++++++++++++++++++ 3 files changed, 29 insertions(+), 22 deletions(-) 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/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/Types.hs b/source/Network/Xmpp/Types.hs index 286f1ac..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)