From 38505a54b28492ad303cad66f07591df3abf2a4d Mon Sep 17 00:00:00 2001
From: Joe Crayne <joe@jerkface.net>
Date: Sun, 9 Sep 2018 17:38:58 -0400
Subject: Provide a different roster resolver for tox-peers to Presence.

---
 Presence/Presence.hs |  1 +
 examples/dhtd.hs     | 38 +++++++++++++++++++++++++++++++++++++-
 2 files changed, 38 insertions(+), 1 deletion(-)

diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index 98d701e9..c3e60239 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -794,6 +794,7 @@ informClientPresence0 state mbk client stanza = do
         atomically $ setClientFlag0 client cf_available
         maybe (return ()) (sendCachedPresence state) mbk
     addrs <- subscribedPeers (manager state $ clientProfile client) (clientUser client) (clientProfile client)
+    dput XJabber $ "informClientPresence(subscribedPeers) "++show (clientProfile client,addrs)
     ktc <- atomically $ readTVar (pkeyToChan state)
     let connected = mapMaybe (flip Map.lookup ktc) addrs
     forM_ connected $ \con -> do
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 92af259c..d5428f93 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -1690,6 +1690,42 @@ onNewToxSession sv ssvar ContactInfo{accounts} addrTox netcrypto = do
 
     return ()
 
+selectManager :: Maybe (t -> ToxManager k) -> Manager status T.Text -> T.Text -> Manager status T.Text
+selectManager (Just tman) tcp profile = case T.splitAt 43 profile of
+    (k,".tox") -> let _ = _
+                      tox = toxConnections $ tman $ error "PresenseState"
+                  in Manager
+                    { resolvePeer = \themhost -> do
+                        r <- fromMaybe (return []) $ do
+                            (themT,".tox") <- Just $ T.splitAt 43 themhost
+                            them <- readMaybe $ T.unpack themT
+                            me <- readMaybe $ T.unpack k
+                            let contact = Tox.ToxContact me them
+                            Just $ resolvePeer tox contact
+                        dput XMan $ "resolvePeer(tox) " ++ show (T.take 8 $ k,T.take 8 $ themhost,r)
+                        return r
+                    , reverseAddress = \paddr -> do
+                        r <- fromMaybe (return []) $ do
+                            me <- readMaybe $ T.unpack k
+                            Just $ do
+                                reverseAddress tox paddr
+                                 <&> mapMaybe (\case
+                                    Tox.ToxContact a k | a == me -> Just $ T.pack (show k) `T.append` ".tox"
+                                    _                            -> Nothing)
+                        dput XMan $ "reverseAddress(tox)" ++ show (T.take 8 k,paddr) ++ ": " ++ show r
+                        return r
+                    }
+    _          -> tcp
+selectManager _ tcp profile = tcp
+                    { resolvePeer = \themhost -> do
+                        dput XMan $ "resolvePeer(tcp) " ++ show (profile,themhost)
+                        resolvePeer tcp themhost
+                    , reverseAddress = \paddr -> do
+                        dput XMan $ "reverseAddress(tcp) " ++ show (profile,paddr)
+                        reverseAddress tcp paddr
+                    }
+
+
 main :: IO ()
 main = do
     args <- getArgs
@@ -2022,7 +2058,7 @@ main = do
             sv <- xmppServer Tcp.noCleanUp (Just sport)
             tcp <- xmppConnections sv -- :: IO ( Manager TCPStatus T.Text )
             let tman = toxman ssvar announcer toxbkts <$> mbtox
-            state     <- newPresenceState cw tman sv (const tcp)
+            state     <- newPresenceState cw tman sv (selectManager tman tcp)
             forkXmpp sv (presenceHooks state (verbosity opts) (Just cport) (Just sport))
             conns     <- xmppConnections  sv
             return (Just sv, Just conns, Just state)
-- 
cgit v1.2.3