ToxManager reworked stubs.

2 files changed, 56 insertions, 33 deletions

diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index 77689d1e..ed1c5033 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -39,7 +39,8 @@ import Data.XML.Types (Event)
 import System.Posix.Types (UserID,CPid)
 import Control.Applicative
 import Crypto.Error.Types       (CryptoFailable (..))
-import Crypto.PubKey.Curve25519 (publicKey, secretKey, toPublic)
+import Crypto.PubKey.Curve25519 (SecretKey,toPublic)
+import Text.Read (readMaybe)
 
 import LockedChan (LockedChan)
 import TraversableT
@@ -51,6 +52,8 @@ import ConsoleWriter
 import ClientState
 import Util
 import qualified Connection
+import Network.Tox.NodeId (id2key)
+import Crypto.Tox (decodeSecret)
 
 isPeerKey :: ConnectionKey -> Bool
 isPeerKey k = case k of { PeerKey {} -> True ; _ -> False }
@@ -65,9 +68,22 @@ localJID user "." resource = do
 localJID user profile resource =
     return $ user <> "@" <> profile <> "/" <> resource
 
+-- | These hooks will be invoked in order to connect to *.tox hosts in the
+-- user's roster.
+--
+-- The parameter k is a lookup key corresponding to an XMPP client.  Each
+-- unique value should be able to hold a reference to the ToxID identity which
+-- should stay online until all interested keys have run 'deactivateAccount'.
 data ToxManager k = ToxManager
-    { activateAccount        :: k -> Text -> IO ()
+      -- | Put the given ToxID online.
+    { activateAccount        :: k -> Text -> SecretKey -> IO ()
+      -- | Take the given ToxID offline (assuming no other /k/ has a claim).
     , deactivateAccount      :: k -> Text -> IO ()
+      -- | Try to connect to the remote peer (or not).
+      --
+      -- The arguments are our public key (in hostname format) followed by
+      -- their public key (in hostname format) and the Policy to set for this
+      -- link.
     , setToxConnectionPolicy :: Text -> Text -> Connection.Policy -> IO ()
     }
 
@@ -196,9 +212,9 @@ chooseResourceName state k addr clientsNameForMe desired = do
                 -- TODO: Tox key profile.
                 secs <- configText ConfigFiles.getSecrets user wanted_profile
                 case secs of
-                    sec:_ | CryptoPassed s <- secretKey (Text.encodeUtf8 sec)
-                          , CryptoPassed (toPublic s) == publicKey (Text.encodeUtf8 pub)
-                          -> do activateAccount toxman k wanted_profile
+                    sec:_ | Just s <- decodeSecret (Text.encodeUtf8 sec)
+                          , Just (toPublic s) == fmap id2key (readMaybe $ Text.unpack pub)
+                          -> do activateAccount toxman k wanted_profile s
                                 return wanted_profile
                     _     -> do
                             -- XXX: We should probably fail to connect when an
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 73ae5a57..fbfca86f 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -994,6 +994,18 @@ newXmmpSource = _todo
 newXmmpSink :: Tox.NetCryptoSession -> IO (C.Sink (Flush Tox.CryptoMessage) IO ())
 newXmmpSink = _todo
 
+-- | TODO
+--
+-- These hooks will be invoked in order to connect to *.tox hosts in a user's
+-- XMPP roster.
+toxman :: Tox.Tox -> ToxManager k
+toxman tox = ToxManager
+    { activateAccount        = \k pubname seckey -> return ()
+    , deactivateAccount      = \k pubname -> return ()
+    , setToxConnectionPolicy = \me them policy -> return ()
+    }
+
+
 announceToxXMPPClients :: TChan ((ConnectionKey,SockAddr), Tcp.ConnectionEvent XML.Event)
                       -> SockAddr
                       -> SockAddr
@@ -1012,6 +1024,7 @@ announceToxXMPPClients echan laddr saddr pingflag tsrc tsnk
     xsnk = flushPassThrough xmppToTox =$= tsnk
 
 
+
 main :: IO ()
 main = runResourceT $ liftBaseWith $ \resT -> do
     args <- getArgs
@@ -1027,28 +1040,6 @@ main = runResourceT $ liftBaseWith $ \resT -> do
 
     announcer <- forkAnnouncer
 
-    let toxman = ToxManager
-            { activateAccount        = \k pubkey -> return ()
-            , deactivateAccount      = \k pubkey -> return ()
-            , setToxConnectionPolicy = \me them policy -> return ()
-            }
-
-    -- XMPP initialization
-    cw        <- newConsoleWriter
-    serverVar <- atomically $ newEmptyTMVar
-    state     <- newPresenceState cw (Just toxman) serverVar
-
-    -- XMPP stanza handling
-    sv    <- resT $ xmppServer (presenceHooks state (verbosity opts))
-    -- We now have a server object but it's not ready to use until
-    -- we put it into the 'server' field of our /state/ record.
-
-    conns     <- xmppConnections  sv
-
-    atomically $ do
-        putTMVar serverVar  (sv,conns) -- Okay, now it's ready. :)
-                                       -- FIXME: This is error prone.
-
 
     (quitBt,btdhts,btips,baddrs) <- case portbt opts of
         "" -> return (return (), Map.empty,return [],[])
@@ -1145,12 +1136,6 @@ main = runResourceT $ liftBaseWith $ \resT -> do
         "" -> return (Nothing,return (), Map.empty, return [],[])
         toxport -> do
             addrTox <- getBindAddress toxport (ip6tox opts)
-            atomically $ Tox.addNewSessionHook netCryptoSessionsState $ \mbNoSpam netcrypto -> do
-                let Just pingMachine = Tox.ncPingMachine netcrypto
-                    pingflag = readTVar (pingFlag pingMachine)
-                xmppSrc <- newXmmpSource netcrypto
-                xmppSink <- newXmmpSink netcrypto
-                announceToxXMPPClients (xmppEventChannel sv) addrTox (Tox.ncSockAddr netcrypto) pingflag xmppSrc xmppSink
             hPutStrLn stderr $ "Supplied key: " ++ show (fmap (Tox.key2id . toPublic) (dhtkey opts))
             tox <- Tox.newTox keysdb
                               addrTox
@@ -1321,8 +1306,30 @@ main = runResourceT $ liftBaseWith $ \resT -> do
                 ips = readExternals Tox.nodeAddr [ Tox.routing4 $ Tox.toxRouting tox
                                                  , Tox.routing6 $ Tox.toxRouting tox ]
             return (Just tox, quitTox, dhts, ips, [addrTox])
+
     _ <- UPNP.requestPorts "dht-client" $ map (Datagram,) $ baddrs ++ taddrs
 
+    -- XMPP initialization
+    cw        <- newConsoleWriter
+    serverVar <- atomically $ newEmptyTMVar
+    state     <- newPresenceState cw (toxman <$> mbtox) serverVar
+
+    sv    <- resT $ xmppServer (presenceHooks state (verbosity opts))
+    -- We now have a server object but it's not ready to use until
+    -- we put it into the 'server' field of our /state/ record.
+    conns     <- xmppConnections  sv
+    atomically $ do
+        putTMVar serverVar  (sv,conns) -- Okay, now it's ready. :)
+                                       -- FIXME: This is error prone.
+
+    forM_ (take 1 taddrs) $ \addrTox -> do
+        atomically $ Tox.addNewSessionHook netCryptoSessionsState $ \mbNoSpam netcrypto -> do
+            let Just pingMachine = Tox.ncPingMachine netcrypto
+                pingflag = readTVar (pingFlag pingMachine)
+            xmppSrc <- newXmmpSource netcrypto
+            xmppSink <- newXmmpSink netcrypto
+            announceToxXMPPClients (xmppEventChannel sv) addrTox (Tox.ncSockAddr netcrypto) pingflag xmppSrc xmppSink
+
     let dhts = Map.union btdhts toxdhts
 
     (waitForSignal, checkQuit) <- do