Interface to enable Tox users in an XMPP client's roster.

1 files changed, 52 insertions, 9 deletions

diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index 4cb6266a..77689d1e 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -38,6 +38,8 @@ import Data.Int (Int8)
 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 LockedChan (LockedChan)
 import TraversableT
@@ -63,6 +65,12 @@ localJID user "." resource = do
 localJID user profile resource =
     return $ user <> "@" <> profile <> "/" <> resource
 
+data ToxManager k = ToxManager
+    { activateAccount        :: k -> Text -> IO ()
+    , deactivateAccount      :: k -> Text -> IO ()
+    , setToxConnectionPolicy :: Text -> Text -> Connection.Policy -> IO ()
+    }
+
 data PresenceState = forall status. PresenceState
     { clients         :: TVar (Map ConnectionKey ClientState)
     , clientsByUser   :: TVar (Map Text LocalPresence)
@@ -71,24 +79,27 @@ data PresenceState = forall status. PresenceState
     , server          :: TMVar (XMPPServer, Connection.Manager status Text)
     , keyToChan       :: TVar (Map ConnectionKey Conn)
     , consoleWriter   :: Maybe ConsoleWriter
+    , toxManager      :: Maybe (ToxManager ConnectionKey)
     }
 
 
 newPresenceState :: Maybe ConsoleWriter
+                 -> Maybe (ToxManager ConnectionKey)
                  -> TMVar (XMPPServer, Connection.Manager status Text)
                  -> IO PresenceState
-newPresenceState cw xmpp = atomically $ do
+newPresenceState cw toxman xmpp = atomically $ do
         clients <- newTVar Map.empty
         clientsByUser <- newTVar Map.empty
         remotesByPeer <- newTVar Map.empty
         keyToChan <- newTVar Map.empty
         return PresenceState
-            { clients = clients
+            { clients       = clients
             , clientsByUser = clientsByUser
             , remotesByPeer = remotesByPeer
-            , keyToChan = keyToChan
-            , server = xmpp
+            , keyToChan     = keyToChan
+            , server        = xmpp
             , consoleWriter = cw
+            , toxManager    = toxman
             }
 
 
@@ -178,9 +189,26 @@ chooseResourceName state k addr clientsNameForMe desired = do
     user <- getJabberUserForId muid
     status <- atomically $ newTVar Nothing
     flgs <- atomically $ newTVar 0
-    profile <- fmap (fromMaybe ".") $ forM clientsNameForMe $ \wanted_profile -> do
-        -- TODO: allow user to select profile
-        return "."
+    profile <- fmap (fromMaybe ".")
+        $ forM ((,) <$> clientsNameForMe <*> toxManager state) $ \(wanted_profile,toxman) ->
+        case Text.splitAt 43 wanted_profile of
+            (pub,".tox") -> 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
+                                return wanted_profile
+                    _     -> do
+                            -- XXX: We should probably fail to connect when an
+                            -- invalid Tox profile is used.  For now, we'll
+                            -- fall back to the Unix account login.
+                            return "."
+            ("*.tox","") -> do
+                -- TODO: Match single tox key profile or generate first.
+                _todo
+            _ -> return "."
     let client = ClientState { clientResource = maybe "fallback" id mtty
                              , clientUser     = user
                              , clientProfile  = profile
@@ -257,7 +285,13 @@ rosterGetStuff what state k = forClient state k (return [])
       PresenceState { server = svVar } -> do
         (sv,conns) <- atomically $ takeTMVar svVar
         -- Grok peers to associate with from the roster:
-        forM_ hosts $ \host -> Connection.setPolicy conns host Connection.TryingToConnect
+        forM_ hosts $ \host -> do
+            let policySetter = fromMaybe (Connection.setPolicy conns host) $ do
+                    toxman <- toxManager state
+                    (me  , ".tox") <- Just $ Text.splitAt 43 (clientProfile client)
+                    (them, ".tox") <- Just $ Text.splitAt 43 host
+                    Just $ setToxConnectionPolicy toxman (clientProfile client) host
+            policySetter Connection.TryingToConnect
         atomically $ putTMVar svVar (sv,conns)
         return jids
 
@@ -348,6 +382,10 @@ eofConn state k = do
     case k of
         ClientKey {} -> do
             forClient state k (return ()) $ \client -> do
+            forM_ (toxManager state) $ \toxman -> do
+                case Text.splitAt 43 (clientProfile client) of
+                    (pub,".tox") -> deactivateAccount toxman k (clientProfile client)
+                    _            -> return ()
             stanza <- makePresenceStanza "jabber:server" Nothing Offline
             informClientPresence state k stanza
             atomically $ do
@@ -870,8 +908,13 @@ clientSubscriptionRequest state fail k stanza chan = do
                                           , stanzaFrom = Just from })
                                      (connChan con)
         let addrm = Map.fromList (map (,()) addrs)
+            policySetter = fromMaybe (Connection.setPolicy conns h) $ do
+                toxman <- toxManager state
+                (me  , ".tox") <- Just $ Text.splitAt 43 (clientProfile client)
+                (them, ".tox") <- Just $ Text.splitAt 43 h
+                Just $ setToxConnectionPolicy toxman (clientProfile client) h
         -- Add peer if we are not already associated ...
-        Connection.setPolicy conns h Connection.TryingToConnect
+        policySetter Connection.TryingToConnect
         atomically $ putTMVar svVar (sv,conns)