handle presence announcements between peers

1 files changed, 66 insertions, 2 deletions

diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 70f2905a..4c8beec4 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -75,6 +75,7 @@ import Data.Conduit.Blaze
 import Data.List (find)
 import qualified Text.Show.ByteString as L
 import NestingXML
+import           Data.Set as Set (Set)
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 import GHC.Conc 
@@ -528,7 +529,7 @@ handlePeer st src snk = do
     jids <- newTVarIO Set.empty
     session <- newSession session_factory sock
 
-    finally ( src $= parseBytes def $$ fromPeer session )
+    finally ( src $= parseBytes def $$ fromPeer (session,jids) )
         $ do 
             L.putStrLn $ "(P) disconnected " <++> name
             js <- fmap Set.toList (readTVarIO jids)
@@ -536,8 +537,61 @@ handlePeer st src snk = do
             forM_ js $ announcePresence session . offline
             closeSession session
 
+
+handlePeerPresence (session,jids) stanza False = do
+    -- Offline
+    withJust (lookupAttrib "from" (tagAttrs stanza)) $ \jid -> do
+    peer_jid <- liftIO $ parseAddressJID (L.fromChunks [S.encodeUtf8 jid])
+    liftIO . atomically $ do
+        jids_ <- readTVar jids
+        writeTVar jids (Set.delete peer_jid jids_)
+    liftIO $ announcePresence session (Presence peer_jid Offline)
+handlePeerPresence (session,jids) stanza True = do
+    -- online (Available or Away)
+    let log  = liftIO . L.putStrLn . ("(P) " <++>)
+    withJust (lookupAttrib "from" (tagAttrs stanza)) $ \jid -> do
+    pjid <- liftIO $ parseAddressJID (L.fromChunks [S.encodeUtf8 jid])
+    -- stat <- show element content
+    let parseChildren stat = do
+            child <- nextElement
+            case child of
+                Just tag | tagName tag=="{jabber:server}show"
+                                      -> fmap toStat (lift content)
+                Just tag | otherwise  -> parseChildren stat
+                Nothing -> return stat
+        toStat "away" = Away
+        toStat "xa"   = Away -- TODO: xa
+        toStat "dnd"  = Away -- TODO: dnd
+        toStat "chat" = Available
+
+    stat' <- parseChildren Available
+
+    liftIO . atomically $ do
+        jids_ <- readTVar jids
+        writeTVar jids (Set.insert pjid jids_)
+    liftIO $ announcePresence session (Presence pjid stat')
+    log $ bshow (Presence pjid stat')
+
+matchAttribMaybe name (Just value) attrs = 
+    case find ( (==name) . fst) attrs of
+        Just (_,[ContentText x])   | x==value -> True
+        Just (_,[ContentEntity x]) | x==value -> True
+        _                                     -> False
+matchAttribMaybe name Nothing attrs  
+    | find ( (==name) . fst) attrs==Nothing
+    = True
+
+presenceTypeOffline = Just "unavailable"
+presenceTypeOnline  = Nothing
+
+isPresence (EventBeginElement name attrs) testType
+    | name=="{jabber:server}presence"
+    && matchAttribMaybe "type" testType attrs
+    = True
+isPresenceOf _ _ = False
+
 fromPeer :: (MonadThrow m,MonadIO m, XMPPSession session) => 
-    session -> Sink XML.Event m ()
+    (session, TVar (Set JID))  -> Sink XML.Event m ()
 fromPeer session = doNestingXML $ do
     let log  = liftIO . L.putStrLn . ("(P) " <++>)
     withXML $ \begindoc -> do
@@ -552,6 +606,16 @@ fromPeer session = doNestingXML $ do
         whenJust nextElement $ \stanza -> do
             stanza_lvl <- nesting
 
+            let unhandledStanza = do
+                    mb <- lift . runMaybeT $ gatherElement stanza Seq.empty
+                    withJust mb $ \xs -> prettyPrint "P: " (toList xs)
+            case () of
+              _ | stanza `isPresenceOf` presenceTypeOnline
+                    -> handlePeerPresence session stanza True
+              _ | stanza `isPresenceOf` presenceTypeOffline
+                    -> handlePeerPresence session stanza False
+              _ -> unhandledStanza
+
             awaitCloser stanza_lvl
             loop