2 files changed, 85 insertions, 11 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index af392f27..4dda1f70 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -22,6 +22,8 @@ module XMPPServer
     , sendModifiedStanzaToClient
     , presenceProbe
     , presenceSolicitation
+    , makePresenceStanza
+    , JabberShow(..)
     ) where
 
 import Debug.Trace
@@ -746,6 +748,32 @@ grokStanza "jabber:client" stanzaTag =
 mkname :: Text -> Text -> XML.Name
 mkname namespace name = (Name name (Just namespace) Nothing)
 
+makePresenceStanza namespace mjid pstat = do
+    stanzaFromList PresenceStatus { presenceShow = pstat
+                                  , presencePriority = Nothing
+                                  , presenceStatus = []
+                                  }
+      $ [ EventBeginElement (mkname namespace "presence")
+            (setFrom $ typ pstat) ]
+        ++ (shw pstat >>= jabberShow) ++
+        [ EventEndElement (mkname namespace "presence")]
+ where
+    setFrom = maybe id
+                    (\jid -> (attr "from" jid :) )
+                    mjid
+    typ Offline = [attr "type" "unavailable"]
+    typ _       = []
+    shw ExtendedAway = ["xa"]
+    shw Chatty       = ["chat"]
+    shw Away         = ["away"]
+    shw DoNotDisturb = ["dnd"]
+    shw _            = []
+    jabberShow stat = 
+      [ EventBeginElement "{jabber:client}show" []
+      , EventContent (ContentText stat)
+      , EventEndElement "{jabber:client}show" ]
+    
+
 makePong :: Text -> Maybe Text -> Text -> Text -> [XML.Event]
 makePong namespace mid to from =
        -- Note: similar to session reply
diff --git a/xmppServer.hs b/xmppServer.hs
index 107054bf..699c6a7a 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -292,7 +292,24 @@ newConn state k addr outchan = do
     when (isPeerKey k)
         $ sendProbesAndSolicitations state k addr outchan
 
-eofConn state k = atomically $ modifyTVar' (keyToChan state) $ Map.delete k
+eofConn state k = do
+    atomically $ modifyTVar' (keyToChan state) $ Map.delete k
+    case k of
+        ClientKey {} -> do
+            stanza <- makePresenceStanza "{jabber:server}" Nothing Offline
+            informClientPresence state k stanza
+        PeerKey {} -> do
+            let h = peerKeyToText k
+            jids <- atomically $ do
+                rbp <- readTVar (remotesByPeer state)
+                return $ do
+                    umap <- maybeToList $ Map.lookup k rbp
+                    (u,rp) <- Map.toList umap
+                    r <- Map.keys (resources rp)
+                    return $ unsplitJID (Just u, h, Just r)
+            forM_ jids $ \jid -> do
+            stanza <- makePresenceStanza "{jabber:client}" (Just jid) Offline
+            informPeerPresence state k stanza
 
 {-
 rewriteJIDForClient1:: Text -> IO (Maybe ((Maybe Text,Text,Maybe Text),SockAddr))
@@ -427,6 +444,9 @@ deliverMessage state fail msg =
         sendModifiedStanzaToClient dup
                                   chan
 
+-- | Send presence notification to subscribed peers.
+-- Note that a full JID from address will be added to the
+-- stanza if it is not present.
 informClientPresence state k stanza = do
     dup <- cloneStanza stanza
     atomically $ do
@@ -461,9 +481,24 @@ informPeerPresence state k stanza = do
     flip (maybe $ return ()) muser           $ \user -> do
     
     clients <- atomically $ do
-        -- TODO: Store the stanza
+
+        -- Update remotesByPeer...
+        rbp <- readTVar (remotesByPeer state)
+        let umap = maybe Map.empty id $ Map.lookup k rbp
+            rp = case (presenceShow $ stanzaType stanza) of
+                    Offline ->
+                         maybe (Map.empty)
+                               (Map.delete resource . resources)
+                             $ Map.lookup user umap
+                    _ -> maybe (Map.singleton resource ())
+                               (Map.insert resource () . resources )
+                             $ Map.lookup user umap
+            umap' = Map.insert user (RemotePresence rp) umap
+        writeTVar (remotesByPeer state) $ Map.insert k umap' rbp
+        -- TODO: Store or delete the stanza (remotesByPeer)
+        
         -- For now, all clients:
-        -- (TODO: interested/authorized clients only.)
+        -- (TODO: interested/auteorized clients only.)
         ktc <- readTVar (keyToChan state)
         runTraversableT $ do
         (ck,client) <- liftMT $ fmap Map.toList $ readTVar (clients state)
@@ -482,15 +517,21 @@ informPeerPresence state k stanza = do
                                    (connChan con)
 
 answerProbe state k stanza chan = do
-    putStrLn $ "answerProbe! " ++ show (stanzaType stanza)
+    -- putStrLn $ "answerProbe! " ++ show (stanzaType stanza)
     ktc <- atomically $ readTVar (keyToChan state)
-    replies <- runTraversableT $ do
-        to <- liftMaybe $ stanzaTo stanza
-        conn <- liftMaybe $ Map.lookup k ktc
+    muser <- runTraversableT $ do
+        to <- liftT $ stanzaTo stanza
+        conn <- liftT $ Map.lookup k ktc
         let (mu,h,_) = splitJID to -- TODO: currently resource-id is ignored on presence
                                    --  probes.  Is this correct? Check the spec.
-        liftIOMaybe $ guardPortStrippedAddress h (auxAddr conn)
-        u <- liftMaybe mu
+        liftMT $ guardPortStrippedAddress h (auxAddr conn)
+        u <- liftT mu
+        let ch = addrToText (auxAddr conn)
+        return (u,conn,ch)
+
+    flip (maybe $ return ()) muser $ \(u,conn,ch) -> do
+
+    replies <- runTraversableT $ do
         cbu <- lift . atomically $ readTVar (clientsByUser state)
         lpres <- liftMaybe $ Map.lookup u cbu
         clientState <- liftT $ Map.elems (networkClients lpres)
@@ -499,11 +540,16 @@ answerProbe state k stanza chan = do
         let jid = unsplitJID (Just $ clientUser clientState
                              , ch
                              ,Just $ clientResource clientState)
-            ch = addrToText (auxAddr conn)
         return stanza { stanzaFrom = Just jid }
+
     forM_ replies $ \reply -> do
         sendModifiedStanzaToPeer reply chan
-    -- TODO: if null replies, send offline message
+
+    -- if no presence, send offline message
+    when (null replies) $ do
+        let jid = unsplitJID (Just u,ch,Nothing)
+        pstanza <- makePresenceStanza "{jabber:server}" (Just jid) Offline
+        atomically $ writeTChan (connChan conn) pstanza
 
 main = runResourceT $ do
     state <- liftIO . atomically $ do