added some helper functions

src/Network/XMPP.hs

@@ -8,6 +8,8 @@ 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
@@ -17,7 +19,9 @@ import           Data.Text as Text
 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

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
-  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,12 +86,13 @@ 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
+        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