Merge pull request #20 from Philonous/master

incremental changes

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

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

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

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 ()
+endSession :: Session -> IO ()
-endContext session =  do -- TODO: This has to be idempotent (is it?)
+endSession session =  do -- TODO: This has to be idempotent (is it?)
     closeConnection session
     stopThreads session
 

source/Network/Xmpp/Concurrent/Threads.hs

@@ -23,9 +23,10 @@ import           System.Log.Logger
 readWorker :: (Stanza -> IO ())
            -> (XmppFailure -> IO ())
            -> TMVar Stream
-           -> IO a
+           -> IO ()
-readWorker onStanza onConnectionClosed stateRef =
+readWorker onStanza onConnectionClosed stateRef = Ex.mask_ go
-    Ex.mask_ . forever $ do
+  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?
+              Nothing -> go -- Caught an exception, nothing to do. TODO: Can this happen?
-              Just (Left _) -> return ()
+              Just (Left e) -> do
-              Just (Right sta) -> onStanza sta
+                  infoM "Pontarius.Xmpp.Reader" $
-  where
+                          "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,10 +81,7 @@ startThreadsWith :: (Stanza -> IO ())
                   TMVar Stream,
                   ThreadId))
 startThreadsWith stanzaHandler eh con = do
-    rd <- withStream' (gets $ streamSend . streamHandle >>= \d -> return $ Right d) con
+    read' <- withStream' (gets $ streamSend . streamHandle) con
-    case rd of
-        Left e -> return $ Left e
-        Right read' -> do
     writeLock <- newTMVarIO read'
     conS <- newTMVarIO con
     --    lw <- forkIO $ writeWorker outC writeLock

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(..)

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
 

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

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)
     )

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

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
+      Right (ver, from, to, sid, lt, features)
-      -- Successful unpickling of stream element.
-      Right (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)
+    let newSource =loopRead raw $= XP.parseBytes def
-                                        (return ())
+    buffered <- liftIO . bufferSrc $ newSource
-    modify (\s -> s{streamEventSource = 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})
+
+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
-    mapNSHack (NodeElement e) = NodeElement $ nsHack e
+  where
-    mapNSHack n = n
+    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
+    r <- liftIO $ src $$ snk
-    modify (\s -> s{streamEventSource = src'})
+    return  r
-    return $ Right 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
+            Nothing -> do
-            Right Nothing -> do
+                lift $ errorM "Pontarius.XMPP" "pullElement: Stream ended."
-                lift $ errorM "Pontarius.XMPP" "pullElement: No element."
                 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,10 +491,10 @@ xmppNoStream = StreamState {
     , streamJid = Nothing
     , streamConfiguration = def
     }
-  where
+
-    zeroSource :: Source IO output
+zeroSource :: Source IO output
-    zeroSource = liftIO $ do
+zeroSource = liftIO $ do
-        errorM "Pontarius.Xmpp" "zeroSource utilized."
+    errorM "Pontarius.Xmpp" "zeroSource"
     ExL.throwIO XmppOtherFailure
 
 createStream :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (Stream)
@@ -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
+            eSource <- liftIO . bufferSrc $
-                  ((sourceHandle h $= logConduit) $= XP.parseBytes def)
+                         (sourceHandle h $= logConduit) $= XP.parseBytes def
-                  (return ())
+
             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 :: StreamState -> IO Stream
-mkStream con = Stream `fmap` (atomically $ newTMVar con)
+mkStream con = Stream `fmap` atomically (newTMVar con)

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

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

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

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,16 +75,19 @@ iqResponder context = do
     let answerPayload = invertPayload payload
     let answerBody = pickleElem payloadP answerPayload
     unless (payloadCounter payload == 3) . void $
-        answerIQ next (Right $ Just answerBody) context
+        answerIQ next (Right $ Just answerBody)
-    when (payloadCounter payload == 10) $ do
+
-        threadDelay 1000000
-        endContext (session context)
 
 autoAccept :: Xmpp ()
 autoAccept context = forever $ do
-  st <- waitForPresence isPresenceSubscribe 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
     { messageTo = Just to
@@ -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
+-- discoTest debug context = do
-    q <- Disco.queryInfo "species64739.dyndns.org" Nothing context
+--     q <- Disco.queryInfo "species64739.dyndns.org" Nothing context
-    case q of
+--     case q of
-        Left (Disco.DiscoXMLError el e) -> do
+--         Left (Disco.DiscoXMLError el e) -> do
-            debug (ppElement el)
+--             debug (ppElement el)
-            debug (Text.unpack $ ppUnpickleError e)
+--             debug (Text.unpack $ ppUnpickleError e)
-            debug (show $ length $ elementNodes el)
+--             debug (show $ length $ elementNodes el)
-        x -> debug $ show x
+--         x -> debug $ show x
-
+
-    q <-  Disco.queryItems "species64739.dyndns.org"
+--     q <-  Disco.queryItems "species64739.dyndns.org"
-                     (Just "http://jabber.org/protocol/commands") context
+--                      (Just "http://jabber.org/protocol/commands") context
-    case q of
+--     case q of
-        Left (Disco.DiscoXMLError el e) -> do
+--         Left (Disco.DiscoXMLError el e) -> do
-            debug (ppElement el)
+--             debug (ppElement el)
-            debug (Text.unpack $ ppUnpickleError e)
+--             debug (Text.unpack $ ppUnpickleError e)
-            debug (show $ length $ elementNodes el)
+--             debug (show $ length $ elementNodes el)
-        x -> debug $ show x
+--         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
+-- ibrTest debug uname pw = IBR.registerWith [ (IBR.Username, "testuser2")
-    context' <- forkSession context
+--                                  , (IBR.Password, "pwd")
-    forkIO $ action context'
+--                                  ] >>= 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
+  Right context <- session (Text.unpack $ domainpart we)
-      debug' "connect"
+               (Just ([scramSha1 (fromJust $ localpart we) Nothing "pwd"], resourcepart we))
-      connect "localhost" (PortNumber 5222) "species64739.dyndns.org"
+                config
---      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))
   sendPresence presenceOnline context
-  thread1 <- fork autoAccept context
+  thread1 <- forkIO $ autoAccept =<< dupSession context
-  sendPresence (presenceSubscribe them) context
+  thread2 <- forkIO $ iqResponder =<< dupSession context
-  thread2 <- fork iqResponder 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
-    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 +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