updated example, cleanup

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

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

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

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
 
 

src/Network/XMPP/Monad.hs

@@ -88,19 +88,3 @@ xmppFromHandle handle hostname username resource f = runResourceT $ do
              resource
   runStateT f st
 
-
-xml =
-   [ "<?xml version='1.0'?>"
-   , "<stream:stream xmlns='jabber:client' "
-   , "xmlns:stream='http://etherx.jabber.org/streams' id='1365401808' "
-   , "from='examplehost.org' version='1.0' xml:lang='en'>"
-   , "<stream:features>"
-   , "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>"
-   , error "Booh!"
-   ] :: [BS.ByteString]
-
-
-main :: IO ()
-main = (runResourceT $ CL.sourceList xml $= XP.parseBytes def $$ CL.take 2 )
-         >>= print
-

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