1 files changed, 154 insertions, 0 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.
+    }
+