fixed IQ handling

src/Example.hs

@@ -38,9 +38,10 @@ mirror = forever $ do
 main :: IO ()
 main = do
   sessionConnect "localhost" "species64739.dyndns.org" "bot" Nothing $ do
-      singleThreaded $ xmppStartTLS exampleParams
+--      singleThreaded $ xmppStartTLS exampleParams
       singleThreaded $ xmppSASL "pwd"
-      singleThreaded $ xmppBind (Just "botsi")
+      xmppThreadedBind (Just "botsi")
+--      singleThreaded $ xmppBind (Just "botsi")
       singleThreaded $ xmppSession
       forkXMPP autoAccept
       forkXMPP mirror

src/Network/XMPP/Bind.hs

@@ -12,16 +12,19 @@ import Data.XML.Types
 import Network.XMPP.Monad
 import Network.XMPP.Types
 import Network.XMPP.Pickle
+import Network.XMPP.Concurrent
 
+import Control.Monad.IO.Class
 
-bindReqIQ :: Maybe Text -> Stanza
+bindBody :: Maybe Text -> Element
-bindReqIQ rsrc= SIQ $ IQ Nothing Nothing "bind" Set
+bindBody rsrc = (pickleElem
-                    (pickleElem
+                    (bindP . xpOption $ xpElemNodes "resource" (xpContent xpId))
-                      (bindP . xpOption
-                         $ xpElemNodes "resource" (xpContent xpId))
                      rsrc
                  )
 
+bindReqIQ :: Maybe Text -> Stanza
+bindReqIQ rsrc= SIQ $ IQ Nothing Nothing "bind" Set (bindBody rsrc)
+
 jidP :: PU [Node] JID
 jidP = bindP $ xpElemNodes "jid" (xpContent xpPrim)
 
@@ -37,3 +40,14 @@ bindP  :: PU [Node] b -> PU [Node] b
 bindP c = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-bind}bind" c
 
 
+xmppThreadedBind  :: Maybe Text -> XMPPThread Text
+xmppThreadedBind rsrc = do
+   liftIO $ putStrLn "bind..."
+   answer <- sendIQ' Nothing Set (bindBody rsrc)
+   liftIO . putStrLn $ "Answer: " ++ show answer
+   let (IQ Nothing Nothing _ Result b) = answer
+   let (JID _n _d (Just r)) = unpickleElem jidP b
+   return r
+
+
+

src/Network/XMPP/Concurrent.hs

@@ -27,6 +27,7 @@ import qualified Data.Conduit.List as CL
 import           Data.Default (def)
 import           Data.IORef
 import qualified Data.Map as Map
+import           Data.Maybe
 import qualified Data.Text as Text
 import           Data.Text(Text)
 import           Data.Typeable
@@ -78,7 +79,6 @@ readWorker messageC presenceC iqC s = Ex.catch (forever . flip runStateT s $ do
                            return ()
         SIQ       i -> liftIO . atomically $ do
                            writeTChan iqC i
-                           _ <-readTChan iqC
                            return ()
     )
     ( \(ReaderSignal a) -> do
@@ -96,15 +96,12 @@ writeWorker stCh writeR = forever $ do
   _ <- forM outBS write
   atomically $ putTMVar writeR write
 
-
 handleIQs  :: MonadIO m => TVar IQHandlers -> TChan IQ -> m a
 handleIQs handlers iqC = liftIO . forever . atomically $ do
     iq <- readTChan iqC
     (byNS, byID) <- readTVar handlers
-    let iqNS' = nameNamespace . elementName . iqBody $ iq
+    let iqNS = fromMaybe ("") (nameNamespace . elementName . iqBody $ iq)
-    case iqNS' of
+    case iqType iq of
-      Nothing -> return () -- TODO: send error stanza
-      Just iqNS -> case iqType iq of
        Get -> case Map.lookup (Get, iqNS) byNS of
          Nothing -> return () -- TODO: send error stanza
          Just ch -> writeTChan ch iq
@@ -313,7 +310,10 @@ singleThreaded a = do
 
 -- | Sends an IQ, returns a 'TMVar' that will be filled with the first inbound
 -- IQ with a matching ID that has type @result@ or @error@
-sendIQ :: JID -> IQType -> Element -> XMPPThread (TMVar IQ)
+sendIQ :: Maybe JID -- ^ Recipient (to)
+          -> IQType  -- ^ IQ type (Get or Set)
+          -> Element -- ^ The iq body (there has to be exactly one)
+          -> XMPPThread (TMVar IQ)
 sendIQ to tp body = do -- TODO: add timeout
   newId <- liftIO =<< asks idGenerator
   handlers <- asks iqHandlers
@@ -323,7 +323,11 @@ sendIQ to tp body = do -- TODO: add timeout
       writeTVar handlers (byNS, Map.insert newId resRef byId)
         -- TODO: Check for id collisions (shouldn't happen?)
       return resRef
-  sendS . SIQ $ IQ Nothing (Just to) newId tp body
+  sendS . SIQ $ IQ Nothing (to) newId tp body
   return ref
 
-
+-- | like 'sendIQ', but waits for the answer IQ
+sendIQ' :: Maybe JID -> IQType -> Element -> XMPPThread IQ
+sendIQ' to tp body = do
+  ref <- sendIQ to tp body
+  liftIO . atomically $ takeTMVar ref