WIP: Deliver friend-request to xmpp client.

4 files changed, 90 insertions, 17 deletions

diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index 41204818..adae567a 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -109,7 +109,7 @@ data PresenceState = forall status. PresenceState
 
 
 newPresenceState :: Maybe ConsoleWriter
-                 -> Maybe (ToxManager ConnectionKey)
+                 -> Maybe (PresenceState -> ToxManager ConnectionKey)
                  -> TMVar (XMPPServer, Connection.Manager status Text)
                  -> IO PresenceState
 newPresenceState cw toxman xmpp = atomically $ do
@@ -117,15 +117,16 @@ newPresenceState cw toxman xmpp = atomically $ do
         clientsByUser <- newTVar Map.empty
         remotesByPeer <- newTVar Map.empty
         keyToChan <- newTVar Map.empty
-        return PresenceState
-            { clients       = clients
-            , clientsByUser = clientsByUser
-            , remotesByPeer = remotesByPeer
-            , keyToChan     = keyToChan
-            , server        = xmpp
-            , consoleWriter = cw
-            , toxManager    = toxman
-            }
+        let st = PresenceState
+                    { clients       = clients
+                    , clientsByUser = clientsByUser
+                    , remotesByPeer = remotesByPeer
+                    , keyToChan     = keyToChan
+                    , server        = xmpp
+                    , consoleWriter = cw
+                    , toxManager    = Nothing
+                    }
+        return $ st { toxManager = fmap ($ st) toxman }
 
 
 nameForClient :: PresenceState -> ConnectionKey -> IO Text
diff --git a/ToxToXMPP.hs b/ToxToXMPP.hs
index b018e47b..fca8ee30 100644
--- a/ToxToXMPP.hs
+++ b/ToxToXMPP.hs
@@ -1,11 +1,80 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
 module ToxToXMPP where
 
 import Data.Conduit                 as C
 import Data.XML.Types               as XML
 import Network.Tox.Crypto.Transport as Tox
 
+import Announcer
+import Connection
+import Connection.Tox                as Connection
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TChan
+import Control.Monad
+import Crypto.Tox
+import Data.Bits
+import Data.Function
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Set            as Set
+import qualified Data.Text           as T
+         ;import Data.Text           (Text)
+import Data.Word
+import Network.Tox
+import Network.Tox.ContactInfo
+import Network.Tox.DHT.Transport     (FriendRequest (..))
+import Network.Tox.NodeId
+import Network.Tox.Onion.Transport   (OnionData (..))
+import Presence
+import XMPPServer
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent.Lifted
+import GHC.Conc                  (labelThread)
+#endif
+
 xmppToTox :: Conduit XML.Event IO Tox.CryptoMessage
 xmppToTox = _todo
 
 toxToXmpp :: Conduit Tox.CryptoMessage IO XML.Event
 toxToXmpp = _todo
+
+accountJID :: Account -> Text
+accountJID acnt = _todo -- Or perhaps this should be passed in from PresenceState
+
+key2jid :: Word32 -> PublicKey -> Text
+key2jid nospam key = T.pack $ show $ NoSpamId nsp key
+ where
+    nsp = NoSpam nospam (Just sum)
+    sum = nlo `xor` nhi `xor` xorsum key
+    nlo = fromIntegral (0x0FFFF .&. nospam) :: Word16
+    nhi = fromIntegral (0x0FFFF .&. (nospam `shiftR` 16)) :: Word16
+
+dispatch acnt conn (PolicyChange theirkey policy                  ) = return () -- todo
+dispatch acnt conn (OnionRouted  theirkey (OnionDHTPublicKey pkey)) = return () -- todo
+dispatch acnt conn (OnionRouted  theirkey (OnionFriendRequest fr) ) = do
+    let self = accountJID acnt
+        theirjid = key2jid (friendNoSpam fr) theirkey
+    ask <- presenceSolicitation theirjid self
+    sendModifiedStanzaToClient ask (connChan conn)
+
+forkAccountWatcher :: Account -> Tox -> Conn -> IO ThreadId
+forkAccountWatcher acc tox conn = forkIO $ do
+    myThreadId >>= flip labelThread "tox-account"
+    (chan,contacts) <- atomically $ do
+                chan <- dupTChan $ eventChan acc -- duplicate broadcast channel for reading.
+                contacts <- readTVar (contacts acc)
+                return (chan,contacts)
+    -- TODO: process information in contacts HashMap.
+
+    -- Loop endlessly until clientRefs is null.
+    fix $ \loop -> do
+    mev <- atomically $
+            (Just <$> readTChan chan)
+            `orElse` do
+                refs <- readTVar $ clientRefs acc
+                check $ Set.null refs
+                return Nothing
+    forM_ mev $ \ev -> dispatch acc conn ev >> loop
+
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 60d60258..78090794 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -1216,23 +1216,24 @@ 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 -> ToxManager ConnectionKey
-toxman announcer toxbkts tox = ToxManager
+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
-        newlyActive <- atomically $ do
+        (mcon,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)
+            mcon <- fmap ((,) acnt) . Map.lookup k <$> readTVar (keyToChan presence)
             if not (Set.null rs)
-                then return []
+                then return (mcon,[])
                 else do
-                    forM toxbkts $ \(nm,bkts) -> do
+                    fmap ((,) mcon) $ forM toxbkts $ \(nm,bkts) -> do
                         akey <- packAnnounceKey announcer (nm ++ "id:" ++ show pubid)
                         return (akey,bkts)
         forM_ newlyActive $ \(akey,bkts) -> do
@@ -1246,8 +1247,8 @@ toxman announcer toxbkts tox = ToxManager
                                      pubid
                                      toxAnnounceInterval)
                      pub
-            --
-            -- Schedule recurring search for all non-connected contacts.
+
+            forM_ mcon $ \(acnt,conn) -> forkAccountWatcher acnt tox conn
             return ()
     , deactivateAccount      = \k pubname -> do
        bStopped <- fmap (fromMaybe False) $ atomically $ do
@@ -1628,6 +1629,7 @@ main = runResourceT $ liftBaseWith $ \resT -> do
                             [ lookupBkts "tox4" toxdhts
                             , lookupBkts "tox6" toxdhts
                             ]
+
             state     <- newPresenceState cw (toxman announcer toxbkts <$> mbtox) serverVar
 
             sv    <- resT $ xmppServer (presenceHooks state (verbosity opts) (Just cport) (Just sport))
diff --git a/src/Network/Tox/NodeId.hs b/src/Network/Tox/NodeId.hs
index 1f79d1a5..2728a13d 100644
--- a/src/Network/Tox/NodeId.hs
+++ b/src/Network/Tox/NodeId.hs
@@ -105,6 +105,7 @@ packPublicKey ws = BA.allocAndFreeze (8 * length ws) $
         [] -> return ()
         x:xs -> do poke ptr (toBE64 x)
                    loop xs (plusPtr ptr 8)
+{-# NOINLINE packPublicKey #-}
 
 -- We represent the node id redundantly in two formats.  The [Word64] format is
 -- convenient for short-circuiting xor/distance comparisons.  The PublicKey