3 files changed, 45 insertions, 17 deletions

diff --git a/Presence/ConfigFiles.hs b/Presence/ConfigFiles.hs
index d405bd8f..6354d841 100644
--- a/Presence/ConfigFiles.hs
+++ b/Presence/ConfigFiles.hs
@@ -30,7 +30,7 @@ subscriberFile = "subscribers"
 otherFile      = "others"
 pendingFile    = "pending"
 solicitedFile  = "solicited"
-secretsFile    = "secrets"
+secretsFile    = "secret"
 
 
 configPath :: User -> Profile -> String -> IO String
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 "."
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index c9132d0f..bc5e88da 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -89,6 +89,7 @@ import System.Endian (toBE32)
 import Control.Applicative
 import System.IO
 import qualified Connection
+import Util
 
 peerport :: PortNumber
 peerport = 5269
@@ -182,9 +183,12 @@ data XMPPServerParameters =
     { -- | Called when a client requests a resource id.  The first Maybe indicates
       --   the name the client referred to this server by.  The second Maybe is the
       --   client's preferred resource name.
+      --
+      -- Note: The returned domain will be discarded and replaced with the result of
+      -- 'xmppTellMyNameToClient'.
       xmppChooseResourceName :: ConnectionKey -> SockAddr -> Maybe Text -> Maybe Text -> IO Text
     , -- | This should indicate the server's hostname that all client's see.
-      xmppTellMyNameToClient :: IO Text
+      xmppTellMyNameToClient :: ConnectionKey -> IO Text
     , xmppTellMyNameToPeer   :: SockAddr -> IO Text
     , xmppTellClientHisName  :: ConnectionKey -> IO Text
     , xmppTellPeerHisName    :: ConnectionKey -> IO Text
@@ -896,7 +900,7 @@ xmppInbound :: Server ConnectionKey SockAddr ReleaseKey XML.Event
 xmppInbound sv xmpp k laddr pingflag stanzas output donevar = doNestingXML $ do
     let (namespace,tellmyname,tellyourname) = case k of
             ClientKey {} -> ( "jabber:client"
-                            , xmppTellMyNameToClient xmpp
+                            , xmppTellMyNameToClient xmpp k
                             , xmppTellClientHisName xmpp k
                             )
             PeerKey {} -> ( "jabber:server"
@@ -1240,7 +1244,7 @@ forkConnection :: Server ConnectionKey SockAddr ReleaseKey XML.Event
                 ->  IO (TChan Stanza)
 forkConnection sv xmpp k laddr pingflag src snk stanzas = do
     let (namespace,tellmyname) = case k of
-                        ClientKey {} -> ("jabber:client", xmppTellMyNameToClient xmpp)
+                        ClientKey {} -> ("jabber:client", xmppTellMyNameToClient xmpp k)
                         PeerKey {} -> ("jabber:server",xmppTellMyNameToPeer xmpp laddr)
     me <- tellmyname
     rdone <- atomically newEmptyTMVar
@@ -1413,14 +1417,15 @@ xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set)
 sendRoster ::
     StanzaWrap a
     -> XMPPServerParameters
+    -> ConnectionKey
     -> TChan Stanza
     -> IO ()
-sendRoster query xmpp replyto = do
+sendRoster query xmpp clientKey replyto = do
     let k = case stanzaOrigin query of
              NetworkOrigin k _ -> Just k
              LocalPeer -> Nothing -- local peer requested roster?
     flip (maybe $ return ()) k $ \k -> do
-    hostname <- xmppTellMyNameToClient xmpp
+    hostname <- xmppTellMyNameToClient xmpp clientKey
     let getlist f = do
             bs <- f xmpp k
             return (Set.fromList bs) -- js)
@@ -1679,10 +1684,11 @@ monitor sv params xmpp = do
                     case stanzaType stanza of
                         RequestResource clientsNameForMe wanted -> do
                             sockaddr <- socketFromKey sv k
-                            rsc <- xmppChooseResourceName xmpp k sockaddr clientsNameForMe wanted
+                            rsc0 <- xmppChooseResourceName xmpp k sockaddr clientsNameForMe wanted
+                            hostname <- xmppTellMyNameToClient xmpp k
+                            let rsc = unsplitJID (n,hostname,r) where (n,_,r) = splitJID rsc0
                             let reply = iq_bind_reply (stanzaId stanza) rsc
                             -- sendReply quitVar SetResource reply replyto
-                            hostname <- xmppTellMyNameToClient xmpp
                             let requestVersion :: Producer IO XML.Event
                                 requestVersion = do
                                   yield $ EventBeginElement "{jabber:client}iq"
@@ -1711,11 +1717,11 @@ monitor sv params xmpp = do
                                   requestVersion
                               >>= ioWriteChan replyto
                         SessionRequest -> do
-                            me <- xmppTellMyNameToClient xmpp
+                            me <- xmppTellMyNameToClient xmpp k
                             let reply = iq_session_reply (stanzaId stanza) me
                             sendReply quitVar Pong reply replyto
                         RequestRoster -> do
-                            sendRoster stanza xmpp replyto
+                            sendRoster stanza xmpp k replyto
                             xmppSubscribeToRoster xmpp k
                         PresenceStatus {} -> do
                             xmppInformClientPresence xmpp k stanza
@@ -1728,7 +1734,7 @@ monitor sv params xmpp = do
                         NotifyClientVersion name version -> do
                             enableClientHacks name version replyto
                         UnrecognizedQuery query -> do
-                            me <- xmppTellMyNameToClient xmpp
+                            me <- xmppTellMyNameToClient xmpp k
                             let reply = iq_service_unavailable (stanzaId stanza) me query
                             sendReply quitVar (Error ServiceUnavailable (head reply)) reply replyto
                         Message {} -> do