Activate tox user key from xmpp configuration.

1 files changed, 28 insertions, 6 deletions

diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index 97b9d5b8..198012de 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -5,7 +5,9 @@
 {-# LANGUAGE TupleSections             #-}
 module Presence where
 
+import System.Directory
 import System.Environment
+import System.IO.Error
 import System.Posix.Signals
 import Control.Concurrent (threadDelay,forkIO,forkOS,killThread,throwTo)
 import Control.Concurrent.STM
@@ -15,6 +17,7 @@ import Control.Monad.Trans
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Network.Socket ( SockAddr(..), PortNumber )
 import System.Endian (fromBE32)
+import Data.Char
 import Data.List (nub, (\\), intersect, groupBy, sort, sortBy )
 import Data.Ord (comparing )
 import Data.Monoid ( (<>), Sum(..), getSum )
@@ -46,6 +49,7 @@ import Crypto.Error
 #endif
 import Crypto.PubKey.Curve25519 (SecretKey,toPublic)
 import Text.Read (readMaybe)
+import System.IO
 
 import LockedChan (LockedChan)
 import TraversableT
@@ -57,7 +61,7 @@ import ConsoleWriter
 import ClientState
 import Util
 import qualified Connection
-import Network.Tox.NodeId (id2key)
+import Network.Tox.NodeId (id2key,key2id)
 import Crypto.Tox (decodeSecret)
 
 isPeerKey :: ConnectionKey -> Bool
@@ -124,11 +128,22 @@ newPresenceState cw toxman xmpp = atomically $ do
             }
 
 
+nameForClient :: PresenceState -> ConnectionKey -> IO Text
+nameForClient state k = do
+    mc <- atomically $ do
+        cmap <- readTVar (clients state)
+        return $ Map.lookup k cmap
+    case mc of
+        Nothing -> textHostName
+        Just client -> case clientProfile client of
+            "."     -> textHostName
+            profile -> return profile
+
 presenceHooks :: PresenceState -> Int -> Maybe PortNumber -> XMPPServerParameters
 presenceHooks state verbosity mport = XMPPServerParameters
     { xmppChooseResourceName        = chooseResourceName state
     , xmppTellClientHisName         = tellClientHisName state
-    , xmppTellMyNameToClient        = textHostName
+    , xmppTellMyNameToClient        = nameForClient state
     , xmppTellMyNameToPeer          = \addr -> return $ addrToText addr
     , xmppTellPeerHisName           = return . peerKeyToText
     , xmppTellClientNameOfPeer      = flip peerKeyToResolvedName
@@ -212,22 +227,29 @@ chooseResourceName state k addr clientsNameForMe desired = do
     status <- atomically $ newTVar Nothing
     flgs <- atomically $ newTVar 0
     profile <- fmap (fromMaybe ".")
-        $ forM ((,) <$> clientsNameForMe <*> toxManager state) $ \(wanted_profile,toxman) ->
-        case Text.splitAt 43 wanted_profile of
+        $ forM ((,) <$> clientsNameForMe <*> toxManager state) $ \(wanted_profile0,toxman) ->
+        case Text.splitAt 43 wanted_profile0 of
             (pub,".tox") -> do
-                -- TODO: Tox key profile.
+                cdir <- ConfigFiles.configPath (L.fromChunks [Text.encodeUtf8 user]) "." ""
+                cfs  <- map Text.pack <$> listDirectory cdir `catchIOError` (\e -> return [])
+                let profiles = filter (\f -> Text.toLower f == Text.toLower wanted_profile0) cfs
+                -- hPutStrLn stderr $ "Toxmpp profile " ++ show (user,wanted_profile0,profiles,cfs)
+                let wanted_profile = head $ profiles ++ [wanted_profile0]
                 secs <- configText ConfigFiles.getSecrets user wanted_profile
                 case secs of
                     sec:_ | Just s <- decodeSecret (Text.encodeUtf8 sec)
-                          , Just (toPublic s) == fmap id2key (readMaybe $ Text.unpack pub)
+                          , map toLower (show $ key2id $ toPublic s) == map toLower (Text.unpack pub)
                           -> do activateAccount toxman k wanted_profile s
+                                hPutStrLn stderr $ "loaded tox secret " ++ show sec
                                 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.
+                            hPutStrLn stderr "failed to find tox secret"
                             return "."
             ("*.tox","") -> do
+                hPutStrLn stderr $ "TODO: Match single tox key profile or generate first."
                 -- TODO: Match single tox key profile or generate first.
                 _todo
             _ -> return "."