From 5eab69b427f200bfdc06af77b061e66c02436682 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 5 Apr 2012 01:08:12 +0200 Subject: [PATCH] updated example, cleanup --- src/Main.hs | 32 ++++++-------------------------- src/Network/XMPP.hs | 25 ++++++++++++++++++++++--- src/Network/XMPP/Bind.hs | 5 ++--- src/Network/XMPP/Concurrent.hs | 2 +- src/Network/XMPP/Monad.hs | 16 ---------------- src/Network/XMPP/TLS.hs | 4 ++-- 6 files changed, 33 insertions(+), 51 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index b69dcd3..1cff5af 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -39,41 +39,21 @@ mirror = forever $ do (Just $ "you wrote: " `T.append` bd) thr [] _ -> return () --- killer = forever $ do --- st <- readChanS --- case st of --- Message _ _ id tp subject "kill" thr _ -> --- killConnection >> return () --- _ -> return () main :: IO () main = do - putStrLn "hello world" - wait <- newEmptyMVar - connectXMPP "localhost" "species64739.dyndns.org" "bot" (Just "botsi") "pwd" - $ do - liftIO $ putStrLn "----------------------------" - --- sendS . SPresence $ - -- Presence Nothing Nothing Nothing Nothing (Just Available) Nothing Nothing [] + sessionConnect "localhost" "species64739.dyndns.org" "bot" Nothing $ do + singleThreaded $ xmppStartTLS exampleParams + singleThreaded $ xmppSASL "pwd" + singleThreaded $ xmppBind (Just "botsi") + singleThreaded $ xmppSession forkXMPP autoAccept forkXMPP mirror --- withNewThread killer sendS . SPresence $ Presence Nothing Nothing Nothing Nothing (Just Available) Nothing Nothing [] - liftIO $ putStrLn "----------------------------" - sendS . SMessage $ Message Nothing philonous Nothing Nothing Nothing (Just "bla") Nothing [] --- forever $ pullMessage >>= liftIO . print --- withNewThread . void $ (liftIO $ threadDelay 15000000) >> killConnection - - -- forever $ do - -- next <- nextM - -- outStanza $ Message Nothing philonous "" Chat "" "pong!" "" [] - -- liftIO $ print next - liftIO $ putMVar wait () + liftIO . forever $ threadDelay 1000000 return () - takeMVar wait return () diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index 40152b2..dd5ba75 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -1,5 +1,16 @@ {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} -module Network.XMPP where +module Network.XMPP + ( module Network.XMPP.Bind + , module Network.XMPP.Concurrent + , module Network.XMPP.Monad + , module Network.XMPP.SASL + , module Network.XMPP.Session + , module Network.XMPP.Stream + , module Network.XMPP.TLS + , module Network.XMPP.Types + , connectXMPP + , sessionConnect + ) where import Control.Monad import Control.Monad.IO.Class @@ -31,7 +42,7 @@ fromHandle handle hostname username resource password a = -- on it's own xmppStartTLS exampleParams xmppSASL password - xmppBind + xmppBind resource xmppSession runThreaded a return () @@ -47,7 +58,7 @@ fromHandle' handle hostname username resource password a = -- on it's own singleThreaded $ xmppStartTLS exampleParams singleThreaded $ xmppSASL password - singleThreaded $ xmppBind + singleThreaded $ xmppBind resource singleThreaded $ xmppSession a return () @@ -58,3 +69,11 @@ connectXMPP host hostname username resource passwd a = do con <- connectTo host (PortNumber 5222) hSetBuffering con NoBuffering fromHandle' con hostname username resource passwd a + +sessionConnect :: HostName -> Text -> Text + -> Maybe Text -> XMPPThread a -> IO (a, XMPPState) +sessionConnect host hostname username resource a = do + con <- connectTo host (PortNumber 5222) + hSetBuffering con NoBuffering + xmppFromHandle con hostname username resource $ + xmppStartStream >> runThreaded a diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index 249b122..4d1e812 100644 --- a/src/Network/XMPP/Bind.hs +++ b/src/Network/XMPP/Bind.hs @@ -27,9 +27,8 @@ bindReqIQ resource= SIQ $ IQ Nothing Nothing "bind" Set jidP :: PU [Node] JID jidP = bindP $ xpElemNodes "jid" (xpContent xpPrim) -xmppBind :: XMPPMonad () -xmppBind = do - res <- gets sResource +xmppBind :: Maybe Text -> XMPPMonad () +xmppBind res = do push $ bindReqIQ res answer <- pull let SIQ (IQ Nothing Nothing _ Result b) = answer diff --git a/src/Network/XMPP/Concurrent.hs b/src/Network/XMPP/Concurrent.hs index 9909069..c2b6a96 100644 --- a/src/Network/XMPP/Concurrent.hs +++ b/src/Network/XMPP/Concurrent.hs @@ -334,6 +334,6 @@ sendIQ to tp body = do -- TODO: add timeout -- TODO: Check for id collisions (shouldn't happen?) return resRef sendS . SIQ $ IQ Nothing (Just to) newId tp body - return (readTMVar ref) + return ref diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index f80a17c..4449b8d 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -88,19 +88,3 @@ xmppFromHandle handle hostname username resource f = runResourceT $ do resource runStateT f st - -xml = - [ "" - , "" - , "" - , "" - , error "Booh!" - ] :: [BS.ByteString] - - -main :: IO () -main = (runResourceT $ CL.sourceList xml $= XP.parseBytes def $$ CL.take 2 ) - >>= print - diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index d9387b9..c71338d 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -33,7 +33,7 @@ starttlsE = exampleParams :: TLSParams exampleParams = TLS.defaultParams {TLS.pCiphers = TLS.ciphersuite_strong} -xmppStartTLS :: TLSParams -> XMPPMonad Bool +xmppStartTLS :: TLSParams -> XMPPMonad () xmppStartTLS params = do features <- gets sFeatures unless (stls features == Nothing) $ do @@ -51,5 +51,5 @@ xmppStartTLS params = do }) xmppRestartStream modify (\s -> s{sHaveTLS = True}) - gets sHaveTLS + return ()