Factored ToxManager out of the main module.

3 files changed, 156 insertions, 114 deletions

diff --git a/ToxManager.hs b/ToxManager.hs
new file mode 100644
index 00000000..81def17f
--- /dev/null
+++ b/ToxManager.hs
@@ -0,0 +1,154 @@
+{-# LANGUAGE CPP            #-}
+{-# LANGUAGE LambdaCase     #-}
+{-# LANGUAGE NamedFieldPuns #-}
+module ToxManager where
+
+import Announcer
+import Connection
+-- import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Monad
+import Crypto.Tox
+import Data.HashMap.Strict                   as HashMap
+import Data.Maybe
+import qualified Data.Set                    as Set
+import qualified Data.Text                   as T
+import Data.Time.Clock.POSIX
+import Network.Address
+import Network.Kademlia.Routing              as R
+import Network.Kademlia.Search
+import qualified Network.Tox                 as Tox
+import Network.Tox.ContactInfo               as Tox
+import qualified Network.Tox.Crypto.Handlers as Tox
+-- import qualified Network.Tox.DHT.Handlers    as Tox
+import qualified Network.Tox.DHT.Transport   as Tox
+import qualified Network.Tox.Onion.Handlers  as Tox
+import qualified Network.Tox.Onion.Transport as Tox
+import Presence
+import System.IO
+import Text.Read
+import ToxToXMPP
+import XMPPServer                            (ConnectionKey)
+
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent.Lifted
+import GHC.Conc                  (labelThread)
+#endif
+
+toxAnnounceInterval :: POSIXTime
+toxAnnounceInterval = 15
+
+toxAnnounceSendData :: Tox.Tox -> PublicKey
+                               -> Nonce32
+                               -> Maybe Tox.NodeInfo
+                               -> IO (Maybe (Tox.Rendezvous, Tox.AnnounceResponse))
+toxAnnounceSendData tox pubkey token = \case
+    Just ni -> Tox.putRendezvous (Tox.onionTimeout tox)
+                                 (Tox.toxCryptoKeys tox)
+                                 (Tox.toxOnion tox)
+                                 (pubkey :: PublicKey)
+                                 (token :: Nonce32)
+                                 ni
+    Nothing -> return Nothing
+
+
+toxQSearch :: Tox.Tox -> Search Tox.NodeId (IP, PortNumber) Nonce32 Tox.NodeInfo Tox.Rendezvous
+toxQSearch tox = Tox.toxidSearch (Tox.onionTimeout tox) (Tox.toxCryptoKeys tox) (Tox.toxOnion tox)
+
+-- |
+--
+-- These hooks will be invoked in order to connect to *.tox hosts in a user's
+-- XMPP roster.
+toxman :: Announcer -> [(String,TVar (BucketList Tox.NodeInfo))] -> Tox.Tox -> PresenceState -> ToxManager ConnectionKey
+toxman announcer toxbkts tox presence = ToxManager
+    { activateAccount        = \k pubname seckey -> do
+        hPutStrLn stderr $ "toxman ACTIVATE " ++ show (Tox.key2id $ toPublic seckey)
+        let ContactInfo{ accounts } = Tox.toxContactInfo tox
+            pub = toPublic seckey
+            pubid = Tox.key2id pub
+        (acnt,newlyActive) <- atomically $ do
+            macnt <- HashMap.lookup pubid <$> readTVar accounts
+            acnt <- maybe (newAccount seckey) return macnt
+            rs <- readTVar $ clientRefs acnt
+            writeTVar (clientRefs acnt) $! Set.insert k rs
+            modifyTVar accounts (HashMap.insert pubid acnt)
+            if not (Set.null rs)
+                then return (acnt,[])
+                else do
+                    fmap ((,) acnt) $ forM toxbkts $ \(nm,bkts) -> do
+                        akey <- packAnnounceKey announcer (nm ++ "id:" ++ show pubid)
+                        return (akey,bkts)
+        forM_ newlyActive $ \(akey,bkts) -> do
+            -- Schedule recurring announce.
+            --
+            schedule announcer
+                     akey
+                     (AnnounceMethod (toxQSearch tox)
+                                     (Right $ toxAnnounceSendData tox)
+                                     bkts
+                                     pubid
+                                     toxAnnounceInterval)
+                     pub
+
+            forkAccountWatcher acnt tox presence
+            return ()
+
+    , deactivateAccount      = \k pubname -> do
+       hPutStrLn stderr $ "toxman DECTIVATE (todo) 1 " ++ show pubname
+       let ContactInfo{ accounts } = Tox.toxContactInfo tox
+           mpubid = readMaybe $ T.unpack $ T.take 43 pubname
+       bStopped <- fmap (fromMaybe Nothing) $ atomically $ do
+        forM mpubid $ \pubid -> do
+        refs <- do
+            macnt <- HashMap.lookup pubid <$> readTVar accounts
+            rs <- fromMaybe Set.empty <$> mapM (readTVar . clientRefs) macnt
+            forM_ macnt $ \acnt -> do
+                modifyTVar' (clientRefs acnt) $ Set.delete k
+            return rs
+        if (Set.null $ refs Set.\\ Set.singleton k) then do
+            --   TODO
+            --   If this is the last reference to a non-connected contact:
+            --      Stop the recurring search for that contact
+            --
+            -- Stop recurring announce.
+            fmap Just $ forM toxbkts $ \(nm,bkts) -> do
+                akey <- packAnnounceKey announcer (nm ++ "id:" ++ show pubid)
+                return (akey,bkts)
+        else return Nothing
+       forM_ bStopped $ \kbkts -> do
+           hPutStrLn stderr $ "toxman DECTIVATE (todo) 3 " ++ show pubname
+           let Just pubid = mpubid
+               pub        = Tox.id2key pubid
+           forM_ kbkts $ \(akey,bkts) -> do
+                cancel announcer
+                     akey
+                     (AnnounceMethod (toxQSearch tox)
+                                     (Right $ toxAnnounceSendData tox)
+                                     bkts
+                                     pubid
+                                     toxAnnounceInterval)
+                     pub
+
+    , setToxConnectionPolicy = \me them p -> do
+       let m = do meid   <- readMaybe $ T.unpack $ T.take 43 me
+                  themid <- readMaybe $ T.unpack $ T.take 43 them
+                  return $ Tox.Key meid themid
+       hPutStrLn stderr $ "toxman ConnectionPolicy " ++ show (me,them,p,fmap (const ()) m)
+       forM_  m $ \k -> do
+       setPolicy (Tox.toxMgr tox) k p
+       case p of
+        TryingToConnect -> do
+            let db@ContactInfo{ accounts } = Tox.toxContactInfo tox
+            sequence_ $ do
+            let Tox.Key meid themid = k
+            Just $ atomically $ do
+            accs <- readTVar accounts
+            case HashMap.lookup meid accs of
+                Nothing  -> return () -- Unknown account.
+                Just acc -> setContactPolicy (Tox.id2key themid) TryingToConnect acc
+            -- If unscheduled and unconnected, schedule recurring search for this contact.
+        _ -> return () -- Remove contact.
+    }
+
diff --git a/dht-client.cabal b/dht-client.cabal
index 0ac652ce..9dc5ceb9 100644
--- a/dht-client.cabal
+++ b/dht-client.cabal
@@ -141,6 +141,7 @@ library
                     PingMachine
                     Connection
                     ToxToXMPP
+                    ToxManager
 
   build-depends:      base
                     , containers
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 56d9544d..28e9f261 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -67,6 +67,7 @@ import System.Posix.Signals
 
 
 import Announcer
+import ToxManager
 import Crypto.Tox -- (zeros32,SecretKey,PublicKey, generateSecretKey, toPublic, encodeSecret, decodeSecret, userKeys)
 import Network.UPNP as UPNP
 import Network.Address hiding (NodeId, NodeInfo(..))
@@ -1300,120 +1301,6 @@ newXmmpSink session@(Tox.NCrypto { ncOutgoingQueue = outGoingQVar, ncPacketQueue
     liftIO $ sendit session flush_cyptomessage
 
 
-toxAnnounceSendData :: Tox.Tox -> PublicKey
-                               -> Nonce32
-                               -> Maybe Tox.NodeInfo
-                               -> IO (Maybe (Tox.Rendezvous, Tox.AnnounceResponse))
-toxAnnounceSendData tox pubkey token = \case
-    Just ni -> Tox.putRendezvous (Tox.onionTimeout tox)
-                                 (Tox.toxCryptoKeys tox)
-                                 (Tox.toxOnion tox)
-                                 (pubkey :: PublicKey)
-                                 (token :: Nonce32)
-                                 ni
-    Nothing -> return Nothing
-
-toxQSearch :: Tox.Tox -> Search Tox.NodeId (IP, PortNumber) Nonce32 Tox.NodeInfo Tox.Rendezvous
-toxQSearch tox = Tox.toxidSearch (Tox.onionTimeout tox) (Tox.toxCryptoKeys tox) (Tox.toxOnion tox)
-
-toxAnnounceInterval :: POSIXTime
-toxAnnounceInterval = 15
-
--- |
---
--- These hooks will be invoked in order to connect to *.tox hosts in a user's
--- XMPP roster.
-toxman :: Announcer -> [(String,TVar (BucketList Tox.NodeInfo))] -> Tox.Tox -> PresenceState -> ToxManager ConnectionKey
-toxman announcer toxbkts tox presence = ToxManager
-    { activateAccount        = \k pubname seckey -> do
-        hPutStrLn stderr $ "toxman ACTIVATE " ++ show (Tox.key2id $ toPublic seckey)
-        let ContactInfo{ accounts } = Tox.toxContactInfo tox
-            pub = toPublic seckey
-            pubid = Tox.key2id pub
-        (acnt,newlyActive) <- atomically $ do
-            macnt <- HashMap.lookup pubid <$> readTVar accounts
-            acnt <- maybe (newAccount seckey) return macnt
-            rs <- readTVar $ clientRefs acnt
-            writeTVar (clientRefs acnt) $! Set.insert k rs
-            modifyTVar accounts (HashMap.insert pubid acnt)
-            if not (Set.null rs)
-                then return (acnt,[])
-                else do
-                    fmap ((,) acnt) $ forM toxbkts $ \(nm,bkts) -> do
-                        akey <- packAnnounceKey announcer (nm ++ "id:" ++ show pubid)
-                        return (akey,bkts)
-        forM_ newlyActive $ \(akey,bkts) -> do
-            -- Schedule recurring announce.
-            --
-            schedule announcer
-                     akey
-                     (AnnounceMethod (toxQSearch tox)
-                                     (Right $ toxAnnounceSendData tox)
-                                     bkts
-                                     pubid
-                                     toxAnnounceInterval)
-                     pub
-
-            forkAccountWatcher acnt tox presence
-            return ()
-
-    , deactivateAccount      = \k pubname -> do
-       hPutStrLn stderr $ "toxman DECTIVATE (todo) 1 " ++ show pubname
-       let ContactInfo{ accounts } = Tox.toxContactInfo tox
-           mpubid = readMaybe $ T.unpack $ T.take 43 pubname
-       bStopped <- fmap (fromMaybe Nothing) $ atomically $ do
-        forM mpubid $ \pubid -> do
-        refs <- do
-            macnt <- HashMap.lookup pubid <$> readTVar accounts
-            rs <- fromMaybe Set.empty <$> mapM (readTVar . clientRefs) macnt
-            forM_ macnt $ \acnt -> do
-                modifyTVar' (clientRefs acnt) $ Set.delete k
-            return rs
-        if (Set.null $ refs Set.\\ Set.singleton k) then do
-            --   TODO
-            --   If this is the last reference to a non-connected contact:
-            --      Stop the recurring search for that contact
-            --
-            -- Stop recurring announce.
-            fmap Just $ forM toxbkts $ \(nm,bkts) -> do
-                akey <- packAnnounceKey announcer (nm ++ "id:" ++ show pubid)
-                return (akey,bkts)
-        else return Nothing
-       forM_ bStopped $ \kbkts -> do
-           hPutStrLn stderr $ "toxman DECTIVATE (todo) 3 " ++ show pubname
-           let Just pubid = mpubid
-               pub        = Tox.id2key pubid
-           forM_ kbkts $ \(akey,bkts) -> do
-                cancel announcer
-                     akey
-                     (AnnounceMethod (toxQSearch tox)
-                                     (Right $ toxAnnounceSendData tox)
-                                     bkts
-                                     pubid
-                                     toxAnnounceInterval)
-                     pub
-
-    , setToxConnectionPolicy = \me them p -> do
-       let m = do meid   <- readMaybe $ T.unpack $ T.take 43 me
-                  themid <- readMaybe $ T.unpack $ T.take 43 them
-                  return $ Tox.Key meid themid
-       hPutStrLn stderr $ "toxman ConnectionPolicy " ++ show (me,them,p,fmap (const ()) m)
-       forM_  m $ \k -> do
-       setPolicy (Tox.toxMgr tox) k p
-       case p of
-        TryingToConnect -> do
-            let db@ContactInfo{ accounts } = Tox.toxContactInfo tox
-            sequence_ $ do
-            let Tox.Key meid themid = k
-            Just $ atomically $ do
-            accs <- readTVar accounts
-            case HashMap.lookup meid accs of
-                Nothing  -> return () -- Unknown account.
-                Just acc -> setContactPolicy (Tox.id2key themid) TryingToConnect acc
-            -- If unscheduled and unconnected, schedule recurring search for this contact.
-        _ -> return () -- Remove contact.
-    }
-
 -- | Called upon a new Tox friend-connection session with a remote peer in
 -- order to set up translating conduits that simulate a remote XMPP server.
 announceToxJabberPeer :: PublicKey -- ^ Remote tox node's long-term user key.