From 42061ac9d48a09de2cc3c09e2f6d9c60a7ec45b6 Mon Sep 17 00:00:00 2001
From: Joe Crayne <joe@jerkface.net>
Date: Sat, 3 Nov 2018 00:39:27 -0400
Subject: More uniform handling for Tox and XMPP peers.

This is a continuation of the work done in the following commits:

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

	fbf9890a Moved resolving duty to Connection manager.
---
 examples/dhtd.hs | 39 +++++++++++++++++++++++++++++++++------
 1 file changed, 33 insertions(+), 6 deletions(-)

(limited to 'examples/dhtd.hs')

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 481129b3..892fc88c 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -122,7 +122,7 @@ import XMPPServer
 import Connection
 import ToxToXMPP
 import XMPPToTox
-import qualified Connection.Tcp as Tcp (ConnectionEvent(..),noCleanUp)
+import qualified Connection.Tcp as Tcp (ConnectionEvent(..),noCleanUp,TCPStatus)
 import Control.Concurrent.Supply
 import qualified Data.CyclicBuffer as CB
 import DPut
@@ -1690,10 +1690,19 @@ 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 _ = _
+selectManager :: Maybe (t -> ToxManager clientAddress) -> Manager Tcp.TCPStatus T.Text -> T.Text -> Manager Pending T.Text
+selectManager mtman tcp profile = case T.splitAt 43 profile of
+    (k,".tox") | Just tman <- mtman
+               -> let _ = _
+                      -- The following error call is safe because the toxConnections field
+                      -- does not make use of the PresenceState passed to tman.
                       tox = toxConnections $ tman $ error "PresenseState"
+                      tkey them = do
+                        me <- readMaybe (T.unpack k)
+                        them <- case T.splitAt 43 them of
+                            (them0,".tox") -> readMaybe (T.unpack them0)
+                            _              -> Nothing
+                        return (Tox.ToxContact me them)
                   in Manager
                     { resolvePeer = \themhost -> do
                         r <- fromMaybe (return []) $ do
@@ -1714,15 +1723,33 @@ selectManager (Just tman) tcp profile = case T.splitAt 43 profile of
                                     _                            -> Nothing)
                         dput XMan $ "reverseAddress(tox)" ++ show (T.take 8 k,paddr) ++ ": " ++ show r
                         return r
+
+                    , setPolicy = \them -> case tkey them of
+                        Just tk -> \p -> setPolicy tox tk p
+                        Nothing -> \p -> return ()
+                    , status =  \them -> case tkey them of
+                        Just tk -> fmap ToxStatus <$> status tox tk
+                        Nothing -> return $ Connection Dormant RefusingToConnect
+                    , connections = let valid (Tox.ToxContact local them) = do
+                                            guard $ T.pack (show local) == k
+                                            return $ T.pack (show them ++ ".tox")
+                                    in fmap (mapMaybe valid) $ connections tox
+                    , stringToKey = \s -> Just $ T.pack (s ++ ".tox")
+                    , showProgress = \(ToxStatus stat) -> showProgress tox stat
                     }
-    _          -> tcp
-selectManager _ tcp profile = tcp
+    _ -> Manager
                     { 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
+
+                    , setPolicy = setPolicy tcp
+                    , status =  \k -> fmap XMPPStatus <$> status tcp k
+                    , connections = connections tcp
+                    , stringToKey = stringToKey tcp
+                    , showProgress = \(XMPPStatus stat) -> showProgress tcp stat
                     }
 
 
-- 
cgit v1.2.3