From ca3ad13ac31fb587f69f49a14188fd31bea04386 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 8 May 2012 14:33:49 +0200 Subject: [PATCH] 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 | 4 +- src/Network/XMPP/IM.hs | 79 +++------------------------- src/Network/XMPP/{ => IM}/Message.hs | 2 +- src/Network/XMPP/IM/Presence.hs | 74 ++++++++++++++++++++++++++ src/Tests.hs | 48 +++++++++-------- 5 files changed, 110 insertions(+), 97 deletions(-) rename src/Network/XMPP/{ => IM}/Message.hs (94%) create mode 100644 src/Network/XMPP/IM/Presence.hs diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index d850f15..85285ea 100644 --- a/src/Network/XMPP.hs +++ b/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.Message hiding (message) +import Network.XMPP.IM.Presence hiding (presence) +import Network.XMPP.IM.Message hiding (message) import Network.XMPP.Monad import Network.XMPP.Presence import Network.XMPP.SASL diff --git a/src/Network/XMPP/IM.hs b/src/Network/XMPP/IM.hs index 86d4888..3f9d31f 100644 --- a/src/Network/XMPP/IM.hs +++ b/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.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 \ No newline at end of file +import Network.XMPP.IM.Message +import Network.XMPP.IM.Presence \ No newline at end of file diff --git a/src/Network/XMPP/Message.hs b/src/Network/XMPP/IM/Message.hs similarity index 94% rename from src/Network/XMPP/Message.hs rename to src/Network/XMPP/IM/Message.hs index 61741fc..5aa92b5 100644 --- a/src/Network/XMPP/Message.hs +++ b/src/Network/XMPP/IM/Message.hs @@ -1,6 +1,6 @@ {-# LANGUAGE RecordWildCards #-} -module Network.XMPP.Message +module Network.XMPP.IM.Message ( Message(..) , MessageError(..) , MessageType(..) diff --git a/src/Network/XMPP/IM/Presence.hs b/src/Network/XMPP/IM/Presence.hs new file mode 100644 index 0000000..b039c6a --- /dev/null +++ b/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 \ No newline at end of file diff --git a/src/Tests.hs b/src/Tests.hs index 4ba900d..4b4532d 100644 --- a/src/Tests.hs +++ b/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) - _ -> error "Need either 1 or 2" + 0 -> (testUser2, testUser1,False) let debug' = liftIO . atomically . debug . (("Thread " ++ show number ++ ":") ++) wait <- newEmptyTMVarIO @@ -130,28 +133,31 @@ runMain debug number = do when active $ do liftIO $ threadDelay 1000000 -- Wait for the other thread to go online void . fork $ do - forM [1..10] $ \count -> do - let message = Text.pack . show $ localpart we - let payload = Payload count (even count) (Text.pack $ show count) - let body = pickleElem payloadP payload - debug' "sending" - Right answer <- sendIQ' (Just them) Get Nothing body - debug' "received" - let Right answerPayload = unpickleElem payloadP - (fromJust $ iqResultPayload answer) - expect debug' (invertPayload payload) answerPayload - liftIO $ threadDelay 100000 - sendUser "All tests done" - endSession + forM [1..10] $ \count -> do + let message = Text.pack . show $ localpart we + let payload = Payload count (even count) (Text.pack $ show count) + let body = pickleElem payloadP payload + debug' "sending" + Right answer <- sendIQ' (Just them) Get Nothing body + debug' "received" + let Right answerPayload = unpickleElem payloadP + (fromJust $ iqResultPayload answer) + 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 () - -main = do +run i = do out <- newTChanIO forkIO . forever $ atomically (readTChan out) >>= putStrLn let debugOut = writeTChan out - forkIO $ runMain debugOut 1 - runMain debugOut 2 + forkIO $ runMain debugOut (1 + i) + runMain debugOut (2 + i) + +main = run 0