move Network.XMPP.Message to Network.XMPP.IM.Message

move Network.XMPP.IM to Network.XMPP.IM.Presence
add Network.XMPP.IM

src/Network/XMPP.hs

@@ -149,8 +149,8 @@ import Network
 import qualified Network.TLS as TLS
 import Network.XMPP.Bind
 import Network.XMPP.Concurrent
-import Network.XMPP.IM hiding (presence)
+import Network.XMPP.IM.Presence hiding (presence)
-import Network.XMPP.Message hiding (message)
+import Network.XMPP.IM.Message hiding (message)
 import Network.XMPP.Monad
 import Network.XMPP.Presence
 import Network.XMPP.SASL

src/Network/XMPP/IM.hs

@@ -1,74 +1,7 @@
-module Network.XMPP.IM where
+module Network.XMPP.IM
+  ( module Network.XMPP.IM.Message
+  , module Network.XMPP.IM.Presence
+  ) where
 
-import Data.Text(Text)
+import Network.XMPP.IM.Message
-import Network.XMPP.Types
+import Network.XMPP.IM.Presence
-
--- | An empty presence.
-presence :: Presence
-presence = Presence { presenceID       = Nothing
-                    , presenceFrom     = Nothing
-                    , presenceTo       = Nothing
-                    , presenceLangTag  = Nothing
-                    , presenceType     = Nothing
-                    , presencePayload  = []
-                    }
-
--- | Request subscription with an entity.
-presenceSubscribe :: JID -> Presence
-presenceSubscribe to = presence { presenceTo = Just to
-                                , presenceType = Just Subscribe
-                                }
-
--- | Is presence a subscription request?
-isPresenceSubscribe :: Presence -> Bool
-isPresenceSubscribe pres = presenceType pres == (Just Subscribe)
-
--- | Approve a subscripton of an entity.
-presenceSubscribed :: JID -> Presence
-presenceSubscribed to = presence { presenceTo = Just to
-                                 , presenceType = Just Subscribed
-                                 }
-
--- | Is presence a subscription approval?
-isPresenceSubscribed :: Presence -> Bool
-isPresenceSubscribed pres = presenceType pres == (Just Subscribed)
-
--- | End a subscription with an entity.
-presenceUnsubscribe :: JID -> Presence
-presenceUnsubscribe to = presence { presenceTo = Just to
-                                  , presenceType = Just Unsubscribed
-                                  }
-
--- | Is presence an unsubscription request?
-isPresenceUnsubscribe :: Presence -> Bool
-isPresenceUnsubscribe pres = presenceType pres == (Just Unsubscribe)
-
--- | Signal to the server that the client is available for communication.
-presenceOnline :: Presence
-presenceOnline = presence
-
--- | Signal to the server that the client is no longer available for
--- communication.
-presenceOffline :: Presence
-presenceOffline = presence {presenceType = Just Unavailable}
-
----- Change your status
---status
---  :: Maybe Text     -- ^ Status message
---  -> Maybe ShowType -- ^ Status Type
---  -> Maybe Int      -- ^ Priority
---  -> Presence
---status txt showType prio = presence { presenceShowType = showType
---                                    , presencePriority = prio
---                                    , presenceStatus   = txt
---                                    }
-
--- | Set the current availability status. This implicitly sets the client's
--- status online.
---presenceAvail :: ShowType -> Presence
---presenceAvail showType = status Nothing (Just showType) Nothing
-
--- | Set the current status message. This implicitly sets the client's status
--- online.
---presenceMessage :: Text -> Presence
---presenceMessage txt = status (Just txt) Nothing Nothing

src/Network/XMPP/IM/Message.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE RecordWildCards #-}
 
-module Network.XMPP.Message
+module Network.XMPP.IM.Message
     ( Message(..)
     , MessageError(..)
     , MessageType(..)

src/Network/XMPP/IM/Presence.hs

@@ -0,0 +1,74 @@
+module Network.XMPP.IM.Presence where
+
+import Data.Text(Text)
+import Network.XMPP.Types
+
+-- | An empty presence.
+presence :: Presence
+presence = Presence { presenceID       = Nothing
+                    , presenceFrom     = Nothing
+                    , presenceTo       = Nothing
+                    , presenceLangTag  = Nothing
+                    , presenceType     = Nothing
+                    , presencePayload  = []
+                    }
+
+-- | Request subscription with an entity.
+presenceSubscribe :: JID -> Presence
+presenceSubscribe to = presence { presenceTo = Just to
+                                , presenceType = Just Subscribe
+                                }
+
+-- | Is presence a subscription request?
+isPresenceSubscribe :: Presence -> Bool
+isPresenceSubscribe pres = presenceType pres == (Just Subscribe)
+
+-- | Approve a subscripton of an entity.
+presenceSubscribed :: JID -> Presence
+presenceSubscribed to = presence { presenceTo = Just to
+                                 , presenceType = Just Subscribed
+                                 }
+
+-- | Is presence a subscription approval?
+isPresenceSubscribed :: Presence -> Bool
+isPresenceSubscribed pres = presenceType pres == (Just Subscribed)
+
+-- | End a subscription with an entity.
+presenceUnsubscribe :: JID -> Presence
+presenceUnsubscribe to = presence { presenceTo = Just to
+                                  , presenceType = Just Unsubscribed
+                                  }
+
+-- | Is presence an unsubscription request?
+isPresenceUnsubscribe :: Presence -> Bool
+isPresenceUnsubscribe pres = presenceType pres == (Just Unsubscribe)
+
+-- | Signal to the server that the client is available for communication.
+presenceOnline :: Presence
+presenceOnline = presence
+
+-- | Signal to the server that the client is no longer available for
+-- communication.
+presenceOffline :: Presence
+presenceOffline = presence {presenceType = Just Unavailable}
+
+---- Change your status
+--status
+--  :: Maybe Text     -- ^ Status message
+--  -> Maybe ShowType -- ^ Status Type
+--  -> Maybe Int      -- ^ Priority
+--  -> Presence
+--status txt showType prio = presence { presenceShowType = showType
+--                                    , presencePriority = prio
+--                                    , presenceStatus   = txt
+--                                    }
+
+-- | Set the current availability status. This implicitly sets the client's
+-- status online.
+--presenceAvail :: ShowType -> Presence
+--presenceAvail showType = status Nothing (Just showType) Nothing
+
+-- | Set the current status message. This implicitly sets the client's status
+-- online.
+--presenceMessage :: Text -> Presence
+--presenceMessage txt = status (Just txt) Nothing Nothing

src/Tests.hs

@@ -13,6 +13,7 @@ import           Data.XML.Pickle
 import           Data.XML.Types
 
 import           Network.XMPP
+import           Network.XMPP.IM.Presence
 import           Network.XMPP.Pickle
 
 import           System.Environment
@@ -64,7 +65,9 @@ iqResponder = do
     let answerPayload = invertPayload payload
     let answerBody = pickleElem payloadP answerPayload
     answerIQ next (Right $ Just answerBody)
-    when (payloadCounter payload == 10) endSession
+    when (payloadCounter payload == 10) $ do
+        liftIO $ threadDelay 1000000
+        endSession
 
 autoAccept :: XMPP ()
 autoAccept = forever $ do
@@ -88,6 +91,7 @@ simpleMessage to txt = message
                       , messagePayload = []
                       }
 
+
 sendUser  = sendMessage . simpleMessage supervisor . Text.pack
 
 expect debug x y | x == y = debug "Ok."
@@ -102,10 +106,9 @@ wait3 = liftIO $ threadDelay 1000000
 
 runMain :: (String -> STM ()) -> Int -> IO ()
 runMain debug number = do
-  let (we, them, active) = case number of
+  let (we, them, active) = case number `mod` 2 of
                              1 -> (testUser1, testUser2,True)
-                             2 -> (testUser2, testUser1,False)
+                             0 -> (testUser2, testUser1,False)
-                             _ -> error "Need either 1 or 2"
   let debug' = liftIO . atomically .
                debug . (("Thread " ++ show number ++ ":") ++)
   wait <- newEmptyTMVarIO
@@ -142,16 +145,19 @@ runMain debug number = do
                 expect debug' (invertPayload payload) answerPayload
                 liftIO $ threadDelay 100000
             sendUser "All tests done"
+            debug' "ending session"
+            liftIO . atomically $ putTMVar wait ()
             endSession
       liftIO . atomically $ takeTMVar wait
       return ()
   return ()
 
-
+run i = do
-main = do
   out <- newTChanIO
   forkIO . forever $ atomically (readTChan out) >>= putStrLn
   let debugOut = writeTChan out
-  forkIO $ runMain debugOut 1
+  forkIO $ runMain debugOut (1 + i)
-  runMain debugOut 2
+  runMain debugOut (2 + i)
+
+main = run 0