From e50a0dbd317c28650c6b17f0a951c5736733067e Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Fri, 5 Oct 2012 15:18:13 +0200 Subject: [PATCH] fix IBR always using IQ-Get add IBR unregister method improve TLS debug messages --- source/Data/Conduit/TLS.hs | 6 +- source/Network/Xmpp/Sasl/Common.hs | 4 +- source/Network/Xmpp/Xep/InbandRegistration.hs | 74 +++++++++++++------ source/Network/Xmpp/Xep/ServiceDiscovery.hs | 24 +++++- tests/Tests.hs | 15 +++- 5 files changed, 91 insertions(+), 32 deletions(-) diff --git a/source/Data/Conduit/TLS.hs b/source/Data/Conduit/TLS.hs index cd89aab..33224c1 100644 --- a/source/Data/Conduit/TLS.hs +++ b/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 diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index 21065fe..0adea45 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/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 diff --git a/source/Network/Xmpp/Xep/InbandRegistration.hs b/source/Network/Xmpp/Xep/InbandRegistration.hs index 001cc76..633b024 100644 --- a/source/Network/Xmpp/Xep/InbandRegistration.hs +++ b/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)) $ diff --git a/source/Network/Xmpp/Xep/ServiceDiscovery.hs b/source/Network/Xmpp/Xep/ServiceDiscovery.hs index 53572a2..24440c4 100644 --- a/source/Network/Xmpp/Xep/ServiceDiscovery.hs +++ b/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 -- diff --git a/tests/Tests.hs b/tests/Tests.hs index f19004b..893033d 100644 --- a/tests/Tests.hs +++ b/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