From d8abc3f9569323acc2dcc564b3f3e385eb6bcfe8 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 9 Apr 2012 16:25:20 +0200 Subject: [PATCH] added some helper functions --- src/Network/XMPP.hs | 26 +++++++------ src/Network/XMPP/Concurrent/Monad.hs | 6 ++- src/Network/XMPP/Message.hs | 15 ++++++++ src/Network/XMPP/Presence.hs | 56 ++++++++++++++++++++++++++++ src/Tests.hs | 32 +++++++--------- 5 files changed, 104 insertions(+), 31 deletions(-) create mode 100644 src/Network/XMPP/Message.hs create mode 100644 src/Network/XMPP/Presence.hs diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index 2680dbe..f24ace8 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -8,23 +8,27 @@ module Network.XMPP , module Network.XMPP.Stream , module Network.XMPP.TLS , module Network.XMPP.Types + , module Network.XMPP.Presence + , module Network.XMPP.Message , connectXMPP , sessionConnect ) where -import Data.Text as Text +import Data.Text as Text -import Network -import Network.XMPP.Bind -import Network.XMPP.Concurrent -import Network.XMPP.Monad -import Network.XMPP.SASL -import Network.XMPP.Session -import Network.XMPP.Stream -import Network.XMPP.TLS -import Network.XMPP.Types +import Network +import Network.XMPP.Bind +import Network.XMPP.Concurrent +import Network.XMPP.Message +import Network.XMPP.Monad +import Network.XMPP.Presence +import Network.XMPP.SASL +import Network.XMPP.Session +import Network.XMPP.Stream +import Network.XMPP.TLS +import Network.XMPP.Types -import System.IO +import System.IO --fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> IO ((), XMPPState) fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> XMPPThread a diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index 7b09cdb..8dd0ced 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -124,7 +124,6 @@ waitForPresence f = do else do waitForPresence f - -- | Run an XMPPMonad action in isolation. -- Reader and writer workers will be temporarily stopped -- and resumed with the new session details once the action returns. @@ -141,3 +140,8 @@ singleThreaded a = do liftIO . atomically $ putTMVar writeLock out return () +sendPresence :: Presence -> XMPPThread () +sendPresence = sendS . SPresence + +sendMessage :: Message -> XMPPThread () +sendMessage = sendS . SMessage \ No newline at end of file diff --git a/src/Network/XMPP/Message.hs b/src/Network/XMPP/Message.hs new file mode 100644 index 0000000..e2a9e17 --- /dev/null +++ b/src/Network/XMPP/Message.hs @@ -0,0 +1,15 @@ +module Network.XMPP.Message where + +import Data.Text(Text) +import Data.XML.Types + +import Network.XMPP.Types + +simpleMessage :: JID -> Text -> Message +simpleMessage to txt = + Message Nothing to Nothing Nothing Nothing (Just txt) Nothing [] + +answerMessage :: Message -> Text -> [Element] -> Maybe Message +answerMessage (Message (Just frm) _to id tp subject _txt thread _ext) txt bodies = + Just $ Message Nothing frm id tp subject (Just txt) thread bodies +answerMessage _ _ _ = Nothing \ No newline at end of file diff --git a/src/Network/XMPP/Presence.hs b/src/Network/XMPP/Presence.hs new file mode 100644 index 0000000..dc41198 --- /dev/null +++ b/src/Network/XMPP/Presence.hs @@ -0,0 +1,56 @@ +module Network.XMPP.Presence where + +import Data.Text(Text) +import Network.XMPP.Types + +presenceSubscribe :: JID -> Presence +presenceSubscribe to = Presence Nothing (Just to) Nothing (Just Subscribe) Nothing Nothing Nothing [] + +-- | Is presence a subscription request +isPresenceSubscribe :: Presence -> Bool +isPresenceSubscribe pres = pType pres == (Just Subscribe) + +-- | Approve a subscripton of an entity +presenceSubscribed :: JID -> Presence +presenceSubscribed to = Presence Nothing (Just to) Nothing (Just Subscribed) Nothing Nothing Nothing [] + +-- | Is presence a subscription approval +isPresenceSubscribed :: Presence -> Bool +isPresenceSubscribed pres = pType pres == (Just Subscribed) + +-- | End a subscription with an entity +presenceUnsubscribe :: JID -> Presence +presenceUnsubscribe to = Presence Nothing (Just to) Nothing (Just Unsubscribe) Nothing Nothing Nothing [] + +-- | Is presence an unsubscription request +isPresenceUnsubscribe :: Presence -> Bool +isPresenceUnsubscribe pres = pType pres == (Just Unsubscribe) + +-- | Signals to the server that the client is available for communication +presenceOnline :: Presence +presenceOnline = Presence Nothing Nothing Nothing Nothing Nothing Nothing Nothing [] + +-- | Signals to the server that the client is no longer available for communication. +presenceOffline :: Presence +presenceOffline = Presence Nothing Nothing Nothing (Just Unavailable) Nothing Nothing Nothing [] + +presence + :: Maybe Text -- ^ Status message + -> Maybe ShowType -- ^ Status Type + -> Maybe Int -- ^ Priority + -> Presence +presence txt showType priority = Presence Nothing Nothing Nothing Nothing showType txt priority [] + +-- | Sets the current availability status. This implicitly sets the clients +-- status online +presenceAvail :: ShowType -> Presence +presenceAvail showType = presence Nothing (Just showType) Nothing + +-- | Sets the current status message. This implicitly sets the clients +-- status online +presenceMessage :: Text -> Presence +presenceMessage txt = presence (Just txt) Nothing Nothing + +-- | Adds a recipient to a presence notification +presenceTo :: Presence -> JID -> Presence +presenceTo pres to = pres{pTo = Just to} \ No newline at end of file diff --git a/src/Tests.hs b/src/Tests.hs index f18c6b9..2cc06af 100644 --- a/src/Tests.hs +++ b/src/Tests.hs @@ -60,16 +60,10 @@ iqResponder = do autoAccept :: XMPPThread () autoAccept = forever $ do - st <- pullPresence - case st of - Presence from _ idq (Just Subscribe) _ _ _ _ -> - sendS . SPresence $ - Presence Nothing from idq (Just Subscribed) Nothing Nothing Nothing [] - _ -> return () - -sendUser txt = sendS . SMessage $ Message Nothing superviser Nothing Nothing Nothing - (Just (Text.pack txt)) Nothing [] + st <- waitForPresence isPresenceSubscribe + sendPresence $ presenceSubscribed (fromJust $ pFrom st) +sendUser = sendMessage . simpleMessage superviser . Text.pack expect debug x y | x == y = debug "Ok." | otherwise = do @@ -78,7 +72,6 @@ expect debug x y | x == y = debug "Ok." sendUser failMSG - runMain :: (String -> STM ()) -> Int -> IO () runMain debug number = do let (we, them, active) = case number of @@ -93,19 +86,20 @@ runMain debug number = do singleThreaded $ xmppSASL "pwd" xmppThreadedBind (resource we) singleThreaded $ xmppSession - sendS . SPresence $ Presence Nothing Nothing Nothing Nothing (Just Available) Nothing Nothing [] + sendPresence presenceOnline forkXMPP autoAccept forkXMPP iqResponder -- sendS . SPresence $ Presence Nothing (Just them) Nothing (Just Subscribe) Nothing Nothing Nothing [] let delay = if active then 1000000 else 5000000 - when active . void . forkXMPP . void . forM [1..10] $ \count -> do - let message = Text.pack . show $ node we - let payload = Payload count (even count) (Text.pack $ show count) - let body = pickleElem payloadP payload - answer <- sendIQ' (Just them) Get body - let answerPayload = unpickleElem payloadP (iqBody answer) - expect debug' (invertPayload payload) answerPayload - liftIO $ threadDelay delay + when active . void . forkXMPP $ do + forM [1..10] $ \count -> do + let message = Text.pack . show $ node we + let payload = Payload count (even count) (Text.pack $ show count) + let body = pickleElem payloadP payload + answer <- sendIQ' (Just them) Get body + let answerPayload = unpickleElem payloadP (iqBody answer) + expect debug' (invertPayload payload) answerPayload + liftIO $ threadDelay delay sendUser "All tests done" liftIO . forever $ threadDelay 10000000 return ()