fix IBR always using IQ-Get

add IBR unregister method
improve TLS debug messages

source/Data/Conduit/TLS.hs

@@ -32,13 +32,13 @@ tlsinit :: (MonadIO m, MonadIO m1) =>
                     , TLSCtx Handle
                     )
 tlsinit debug tlsParams handle = do
-    when debug . liftIO $ putStrLn "Debug mode enabled"
+    when debug . liftIO $ putStrLn "TLS with debug mode enabled"
     gen <- liftIO $ (newGenIO :: IO SystemRandom) -- TODO: Find better random source?
     con <- client tlsParams gen handle
     handshake con
     let src = forever $ do
             dt <- liftIO $ recvData con
-            when debug (liftIO $ BS.putStrLn dt)
+            when debug (liftIO $ putStr "in: " >> BS.putStrLn dt)
             yield dt
     let snk = do
             d <- await
@@ -46,7 +46,7 @@ tlsinit debug tlsParams handle = do
                 Nothing -> return ()
                 Just x -> do
                        sendData con (BL.fromChunks [x])
-                       when debug (liftIO $ BS.putStrLn x)
+                       when debug (liftIO $ putStr "out: " >>  BS.putStrLn x)
                        snk
     return ( src
            , snk

source/Network/Xmpp/Sasl/Common.hs

@@ -171,12 +171,12 @@ respond = lift . pushElement . saslResponseE .
 
 
 -- | Run the appropriate stringprep profiles on the credentials.
--- May fail Fails with 'AuthStringPrepError'
+-- May fail with 'AuthStringPrepError'
 prepCredentials :: Text.Text -> Maybe Text.Text -> Text.Text
                 -> SaslM (Text.Text, Maybe Text.Text, Text.Text)
 prepCredentials authcid authzid password = case credentials of
     Nothing -> throwError $ AuthStringPrepError
-    Just (ac, az, pw) -> return (ac, az, pw)
+    Just creds -> return creds
   where
     credentials = do
     ac <- normalizeUsername authcid

source/Network/Xmpp/Xep/InbandRegistration.hs

@@ -22,6 +22,7 @@ import qualified Data.XML.Types as XML
 import           Network.Xmpp.Monad
 import           Network.Xmpp.Pickle
 import           Network.Xmpp.Types
+import           Network.Xmpp.Xep.ServiceDiscovery
 
 
 -- In-Band Registration name space
@@ -30,27 +31,49 @@ ibrns = "jabber:iq:register"
 
 ibrName x = (XML.Name x (Just ibrns) Nothing)
 
-data Query = Query { instructions :: Maybe Text.Text
-                   , registered   :: Bool
-                   , fields       ::[(Field, Maybe Text.Text)]
-                   } deriving Show
-
-emptyQuery = Query Nothing False []
-
-supported = do
-    fs <- other <$> gets sFeatures
-    let fe = XML.Element "{http://jabber.org/features/iq-register}register" [] []
-    return $ fe `elem` fs
-
-
 data IbrError = IbrNotSupported
+              | IbrNoConnection
               | IbrIQError IQError
+
                 deriving (Show)
 instance Error IbrError
 
-query :: Query -> XmppConMonad (Either IbrError Query)
-query x = do
-    answer <- xmppSendIQ' "ibr" Nothing Get Nothing (pickleElem xpQuery x)
+
+data Query = Query { instructions :: Maybe Text.Text
+                   , registered   :: Bool
+                   , remove       :: Bool
+                   , fields       ::[(Field, Maybe Text.Text)]
+                   } deriving Show
+
+emptyQuery = Query Nothing False False []
+
+supported :: XmppConMonad (Either IbrError Bool)
+supported = runErrorT $ fromFeatures <+> fromDisco
+  where
+  fromFeatures = do
+      fs <- other <$> gets sFeatures
+      let fe = XML.Element
+                   "{http://jabber.org/features/iq-register}register"
+                   []
+                   []
+      return $ fe `elem` fs
+  fromDisco = do
+      hn' <- gets sHostname
+      hn <- case hn' of
+          Just h -> return (Jid Nothing h Nothing)
+          Nothing -> throwError IbrNoConnection
+      qi <- lift $ xmppQueryInfo Nothing Nothing
+      case qi of
+          Left e -> return False
+          Right qir -> return $ "jabber:iq:register" `elem` qiFeatures qir
+  f <+> g = do
+            r <- f
+            if r then return r else g
+
+
+query :: IQRequestType -> Query -> XmppConMonad (Either IbrError Query)
+query queryType x = do
+    answer <- xmppSendIQ' "ibr" Nothing queryType Nothing (pickleElem xpQuery x)
     case answer of
         Right IQResult{iqResultPayload = Just b} ->
             case unpickleElem xpQuery b of
@@ -59,6 +82,7 @@ query x = do
                             "RequestField: unpickle failed, got "
                             ++ Text.unpack (ppUnpickleError e)
                             ++ " saw " ++ ppElement b
+        Right _ -> return $ Right emptyQuery -- TODO: That doesn't seem right
         Left e -> return . Left $ IbrIQError e
 
 data RegisterError = IbrError IbrError
@@ -81,24 +105,28 @@ registerWith givenFields = runErrorT $ do
     fields <- case partitionEithers res of
         ([],fs) -> return fs
         (fs,_) -> throwError $ MissingFields fs
-    result <- mapError IbrError . ErrorT .  query $ emptyQuery {fields}
+    result <- mapError IbrError . ErrorT .  query Set $ emptyQuery {fields}
     return result
 
+unregister :: XmppConMonad (Either IbrError Query)
+unregister = query Set $ emptyQuery {remove = True}
+
 requestFields = runErrorT $ do
-    supp <- supported
-    unless supp $ throwError $ IbrNotSupported
-    qr <- ErrorT $ query emptyQuery
+--     supp <- ErrorT supported
+--    unless supp $ throwError $ IbrNotSupported
+    qr <- ErrorT $ query Get emptyQuery
     return $ qr
 
 xpQuery :: PU [XML.Node] Query
 xpQuery = xpWrap
-            (\(is, r, fs) -> Query is r fs)
-            (\(Query is r fs) -> (is, r, fs)) $
+            (\(is, r, u, fs) -> Query is r u fs)
+            (\(Query is r u fs) -> (is, r, u, fs)) $
             xpElemNodes (ibrName "query") $
-              xp3Tuple
+              xp4Tuple
                  (xpOption $
                     xpElemNodes (ibrName "instructions") (xpContent $ xpText))
                  (xpElemExists (ibrName "registered"))
+                 (xpElemExists (ibrName "remove"))
                  (xpAllByNamespace ibrns  ( xpWrap
                                               (\(name,_,c) -> (name, c))
                                               (\(name,c) -> (name,(),c)) $

source/Network/Xmpp/Xep/ServiceDiscovery.hs

@@ -8,6 +8,7 @@ module Network.Xmpp.Xep.ServiceDiscovery
   ( QueryInfoResult(..)
   , Identity(..)
   , queryInfo
+  , xmppQueryInfo
   , Item
   , queryItems
   , DiscoError(..)
@@ -22,8 +23,10 @@ import qualified Data.Text as Text
 import           Data.XML.Pickle
 import           Data.XML.Types
 
-import           Network.Xmpp.Pickle
 import           Network.Xmpp
+import           Network.Xmpp.Monad
+import           Network.Xmpp.Pickle
+import           Network.Xmpp.Types
 
 data DiscoError = DiscoNoQueryElement
                 | DiscoIQError IQError
@@ -78,7 +81,7 @@ xpQueryInfo = xpWrap (\(nd, (feats, ids)) -> QIR nd ids feats)
                      )
 
 -- | Query an entity for it's identity and features
-queryInfo ::  Jid -- ^ Entity to query
+queryInfo :: Jid -- ^ Entity to query
           -> Maybe Text.Text -- ^ Node
           -> Xmpp (Either DiscoError QueryInfoResult)
 queryInfo to node = do
@@ -94,6 +97,23 @@ queryInfo to node = do
   where
     queryBody = pickleElem xpQueryInfo (QIR node [] [])
 
+
+xmppQueryInfo :: Maybe Jid
+     -> Maybe Text.Text
+     -> XmppConMonad (Either DiscoError QueryInfoResult)
+xmppQueryInfo to node = do
+    res <- xmppSendIQ' "info" to Get Nothing queryBody
+    return $ case res of
+        Left e -> Left $ DiscoIQError e
+        Right r -> case iqResultPayload r of
+            Nothing -> Left DiscoNoQueryElement
+            Just p -> case unpickleElem xpQueryInfo p of
+                Left e -> Left $ DiscoXMLError p e
+                Right r -> Right r
+  where
+    queryBody = pickleElem xpQueryInfo (QIR node [] [])
+
+
 --
 -- Items
 --

tests/Tests.hs

@@ -5,6 +5,7 @@ import           Control.Concurrent
 import           Control.Concurrent.STM
 import qualified Control.Exception.Lifted as Ex
 import           Control.Monad
+import           Control.Monad.State
 import           Control.Monad.IO.Class
 
 import           Data.Maybe
@@ -16,6 +17,7 @@ import           Data.XML.Types
 import           Network.Xmpp
 import           Network.Xmpp.IM.Presence
 import           Network.Xmpp.Pickle
+import           Network.Xmpp.Types
 import qualified Network.Xmpp.Xep.ServiceDiscovery as Disco
 import qualified Network.Xmpp.Xep.InbandRegistration as IBR
 
@@ -147,7 +149,9 @@ iqTest debug we them = do
     sendUser "All tests done"
     debug "ending session"
 
-ibrTest debug = IBR.requestFields >>= debug . show
+ibrTest debug = IBR.registerWith [ (IBR.Username, "testuser2")
+                                 , (IBR.Password, "pwd")
+                                 ] >>= debug . show
 
 
 runMain :: (String -> STM ()) -> Int -> Bool -> IO ()
@@ -165,13 +169,18 @@ runMain debug number multi = do
       withConnection $ Ex.catch (do
           connect "localhost" "species64739.dyndns.org"
           startTLS exampleParams
+          debug' "ibr start"
           ibrTest debug'
+          debug' "ibr end"
           saslResponse <- simpleAuth
                             (fromJust $ localpart we) "pwd" (resourcepart we)
           case saslResponse of
               Right _ -> return ()
               Left e -> error $ show e
-          debug' "session standing")
+          debug' "session standing"
+          features <- other `liftM` gets sFeatures
+          liftIO . void $ forM features $ \f -> debug' $ ppElement f
+          )
           (\e -> debug' $ show  (e ::Ex.SomeException))
       sendPresence presenceOnline
       thread1 <- fork autoAccept
@@ -185,6 +194,8 @@ runMain debug number multi = do
         liftIO $ killThread thread1
         liftIO $ killThread thread2
       return ()
+--      liftIO . threadDelay $ 10^6
+      unless multi . void .  withConnection $ IBR.unregister
   return ()
 
 run i multi = do