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.

2 files changed, 39 insertions, 10 deletions

diff --git a/ToxManager.hs b/ToxManager.hs
index 793a3b8a..44b7a5ef 100644
--- a/ToxManager.hs
+++ b/ToxManager.hs
@@ -63,6 +63,8 @@ import Connection
 import Connection.Tcp (TCPStatus)
 import GHC.Conc       (unsafeIOToSTM)
 
+data Pending = ToxStatus ToxProgress | XMPPStatus TCPStatus
+
 
 toxAnnounceSendData :: Tox.Tox JabberClients
                         -> PublicKey
@@ -96,7 +98,7 @@ toxman :: TVar (Map.Map Uniq24 AggregateSession)
             -> Announcer
             -> [(String,TVar (BucketList Tox.NodeInfo))]
             -> Tox.Tox JabberClients
-            -> PresenceState TCPStatus
+            -> PresenceState Pending
             -> ToxManager ClientAddress
 toxman ssvar announcer toxbkts tox presence = ToxManager
     { activateAccount        = \k pubname seckey -> do
@@ -248,7 +250,7 @@ initPerClient = do
 data ToxToXMPP = ToxToXMPP
     { txAnnouncer      :: Announcer
     , txAccount        :: Account JabberClients
-    , txPresence       :: PresenceState TCPStatus
+    , txPresence       :: PresenceState Pending
     , txTox            :: Tox JabberClients
     , txSessions       :: TVar (Map.Map Uniq24 AggregateSession)
     }
@@ -552,7 +554,7 @@ updateRoster tx them = do
 -- | Returns a list of nospam values to use for friend requests to send to a
 -- remote peer.  This list is non-empty only when it is desirable to send
 -- friend requests.
-checkSoliciting :: PresenceState TCPStatus -> PublicKey -> PublicKey -> Contact -> IO [NoSpam]
+checkSoliciting :: PresenceState Pending -> PublicKey -> PublicKey -> Contact -> IO [NoSpam]
 checkSoliciting presence me them contact = do
     let theirhost = T.pack $ show (key2id them) ++ ".tox"
         myhost = T.pack $ show (key2id me) ++ ".tox"
@@ -658,7 +660,7 @@ stopConnecting ToxToXMPP{txAnnouncer=announcer,txAccount=acnt} them reason = do
     cancel announcer akeyD
 
 forkAccountWatcher :: TVar (Map.Map Uniq24 AggregateSession)
-                      -> Account JabberClients -> Tox JabberClients -> PresenceState TCPStatus -> Announcer -> IO ThreadId
+                      -> Account JabberClients -> Tox JabberClients -> PresenceState Pending -> Announcer -> IO ThreadId
 forkAccountWatcher ssvar acc tox st announcer = forkIO $ do
     myThreadId >>= flip labelThread ("online:"
                                       ++ show (key2id $ toPublic $ userSecret acc))
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
                     }