reply to probes (untested)

2 files changed, 47 insertions, 12 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 0103ba46..e66eea70 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -183,6 +183,7 @@ data XMPPServerParameters =
     , xmppTellClientNameOfPeer :: ConnectionKey -> IO Text
     , xmppDeliverMessage :: (IO ()) -> Stanza -> IO ()
     , xmppInformClientPresence :: ConnectionKey -> Stanza -> IO ()
+    , xmppAnswerProbe :: ConnectionKey -> Stanza -> TChan Stanza -> IO ()
     }
 
 
@@ -1569,6 +1570,10 @@ monitor sv params xmpp = do
                                 guard . not . null . mapMaybe (msgBody . snd) $ msgLangMap (stanzaType stanza)
                                 stanzaId stanza
                         _ -> return ()
+                NetworkOrigin k@(PeerKey {}) replyto ->
+                    case stanzaType stanza of
+                        PresenceRequestStatus {} -> do
+                            xmppAnswerProbe xmpp k stanza replyto
                 _ -> return ()
             let deliver replyto = do
                     -- TODO: Issuing RecipientUnavailable for all errors is a presence leak
diff --git a/xmppServer.hs b/xmppServer.hs
index a30d15d0..27ae7941 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -30,7 +30,7 @@ import Control.Exception ({-evaluate,-}handle,SomeException(..),bracketOnError,E
 import System.Posix.User (getUserEntryForID,userName)
 import qualified Data.ByteString.Lazy.Char8 as L
 import qualified ConfigFiles
-import Data.Maybe (listToMaybe,mapMaybe)
+import Data.Maybe (maybeToList,listToMaybe,mapMaybe)
 
 import TraversableT
 import UTmp (ProcessID,users)
@@ -77,6 +77,7 @@ data ClientState = ClientState
     { clientResource :: Text
     , clientUser :: Text
     , clientPid :: Maybe ProcessID
+    , clientStatus :: TVar (Maybe Stanza)
     }
 
 
@@ -155,9 +156,11 @@ chooseResourceName state k addr desired = do
     muid <- getLocalPeerCred' addr
     (mtty,pid) <- getTTYandPID muid
     user <- getJabberUserForId muid
+    status <- atomically $ newTVar Nothing
     let client = ClientState { clientResource = maybe "fallback" id mtty
                              , clientUser = user
-                             , clientPid = pid }
+                             , clientPid = pid
+                             , clientStatus = status }
 
     atomically $ do
         modifyTVar' (clients state) $ Map.insert k client
@@ -325,6 +328,16 @@ rewriteJIDForClient laddr jid = do
                   else peerKeyToResolvedName (PeerKey addr)
     return (mine,(n,h',r))
 
+addrTextToKey h = do
+    maddr <- parseAddress (strip_brackets h)
+    return (fmap PeerKey maddr)
+
+guardPortStrippedAddress h laddr = do
+    maddr <- fmap (fmap (`withPort` 0)) $ parseAddress (strip_brackets h)
+    let laddr' = laddr `withPort` 0
+    return $ maddr >>= guard . (==laddr')
+
+
 -- | Accepts a textual representation of a domainname
 -- JID suitable for client connections, and returns the
 -- coresponding ipv6 address JID suitable for peers paired
@@ -393,6 +406,30 @@ deliverMessage state fail msg =
         sendModifiedStanzaToClient dup
                                   chan
 
+informClientPresence state k stanza = do
+    dup <- cloneStanza stanza
+    atomically $ do
+        mb <- fmap (Map.lookup k) $ readTVar (clients state)
+        flip (maybe $ return ()) mb $ \cstate -> do
+        writeTVar (clientStatus cstate) $ Just dup
+
+answerProbe state k stanza chan = do
+    ktc <- atomically $ readTVar (keyToChan state)
+    replies <- runTraversableT $ do
+        let liftMaybe = liftT . maybeToList
+            liftIOMaybe = liftMT . fmap maybeToList
+        to <- liftMaybe $ stanzaTo stanza
+        conn <- liftMaybe $ Map.lookup k ktc
+        let (mu,h,_) = splitJID to -- TODO: currently resource-id is ignored on presence
+                                   --  probes.  Is this correct? Check the spec.
+        cbu <- lift . atomically $ readTVar (clientsByUser state)
+        lpres <- liftMaybe $ Map.lookup u cbu
+        clientState <- liftT $ Map.elems (networkClients lpres)
+        mstanza <- lift $ atomically (readTVar (clientStatus clientState))
+        liftMaybe mstanza
+    forM_ replies $ \reply -> do
+        sendModifiedStanzaToPeer reply chan
+    -- TODO: if null replies, send offline message
 
 main = runResourceT $ do
     state <- liftIO . atomically $ do
@@ -425,16 +462,9 @@ main = runResourceT $ do
         , xmppRosterSolicited = rosterGetSolicited state
         , xmppRosterOthers = rosterGetOthers state
         , xmppSubscribeToRoster = \k -> return ()
-        -- , xmppLookupClientJID = \k -> return $ "nobody@" <> hostname <> "/tty666"
-        , {- xmppDeliverMessage = \fail msg -> do
-            let msgs = msgLangMap (stanzaType msg)
-                body = fmap (maybe "" id . msgBody . snd) $ take 1 msgs
-            when (not $ null body) $ do
-            Text.putStrLn $ "MESSAGE " <> head body
-            return ()
-          -}
-          xmppDeliverMessage = deliverMessage state
-        , xmppInformClientPresence = \k stanza -> return ()
+        , xmppDeliverMessage = deliverMessage state
+        , xmppInformClientPresence = informClientPresence state
+        , xmppAnswerProbe = answerProbe state
         }
     liftIO $ do
     atomically $ putTMVar (server state) sv