added some helper functions

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
-import           Network.XMPP.Bind
+import Network.XMPP.Bind
-import           Network.XMPP.Concurrent
+import Network.XMPP.Concurrent
-import           Network.XMPP.Monad
+import Network.XMPP.Message
-import           Network.XMPP.SASL
+import Network.XMPP.Monad
-import           Network.XMPP.Session
+import Network.XMPP.Presence
-import           Network.XMPP.Stream
+import Network.XMPP.SASL
-import           Network.XMPP.TLS
+import Network.XMPP.Session
-import           Network.XMPP.Types
+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

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

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

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}

src/Tests.hs

@@ -60,16 +60,10 @@ iqResponder = do
 
 autoAccept :: XMPPThread ()
 autoAccept = forever $ do
-  st <- pullPresence
+  st <- waitForPresence isPresenceSubscribe
-  case st of
+  sendPresence $ presenceSubscribed (fromJust $ pFrom st)
-    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 []
 
+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
+      when active . void . forkXMPP $ do
-        let message = Text.pack . show $ node we
+        forM [1..10] $ \count -> do
-        let payload = Payload count (even count) (Text.pack $ show count)
+            let message = Text.pack . show $ node we
-        let body = pickleElem payloadP payload
+            let payload = Payload count (even count) (Text.pack $ show count)
-        answer <- sendIQ' (Just them) Get body
+            let body = pickleElem payloadP payload
-        let answerPayload = unpickleElem payloadP (iqBody answer)
+            answer <- sendIQ' (Just them) Get body
-        expect debug' (invertPayload payload) answerPayload
+            let answerPayload = unpickleElem payloadP (iqBody answer)
-        liftIO $ threadDelay delay
+            expect debug' (invertPayload payload) answerPayload
+            liftIO $ threadDelay delay
         sendUser "All tests done"
       liftIO  . forever $ threadDelay 10000000
       return ()