Provide a different roster resolver for tox-peers to Presence.

1 files changed, 37 insertions, 1 deletions

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)