Activate tox user key from xmpp configuration.

5 files changed, 61 insertions, 21 deletions

diff --git a/Connection.hs b/Connection.hs
index 3287bc1b..a3004c11 100644
--- a/Connection.hs
+++ b/Connection.hs
@@ -19,6 +19,7 @@ data Policy
     = RefusingToConnect
     | OpenToConnect
     | TryingToConnect
+ deriving (Eq,Ord,Show)
 
 data Connection status = Connection
     { connStatus    :: STM (Status status)
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
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index fcb02ace..3e48e4bb 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -38,6 +38,7 @@ import qualified Data.IntMap.Strict as IntMap
 import qualified Data.Map.Strict as Map
 import Data.Maybe
 import qualified Data.Set        as Set
+import Data.Tuple
 import Data.Time.Clock
 import qualified Data.XML.Types  as XML
 import GHC.Conc (threadStatus,ThreadStatus(..))
@@ -587,7 +588,10 @@ clientSession s@Session{..} sock cnum h = do
                                                   ++ [mappend " *" . show . Tox.key2id $ pubkey]
                         switchKey $ Just pubkey
                  | "secrets"    <- strp s -> cmd0 $ do
-                        ks <- atomically $ readTVar userkeys
+                        ks <- atomically $ do
+                                uks <- readTVar userkeys
+                                as <- readTVar (accounts roster)
+                                return $ uks ++ map ((userSecret *** Tox.id2key) . swap) (HashMap.toList as)
                         skey <- maybe (return Nothing) (atomically . dhtSecretKey)
                                       $ Map.lookup netname dhts
                         hPutClient h . showReport $ map mkrow ks ++ case skey >>= encodeSecret of
@@ -999,7 +1003,7 @@ sensibleDefaults = Options
     , ip6bt     = True
     , ip6tox    = True
     , dhtkey    = Nothing
-    , verbosity = 1
+    , verbosity = 2
     }
 
 -- bt=<port>,tox=<port>
@@ -1008,6 +1012,8 @@ parseArgs :: [String] -> Options -> Options
 parseArgs []                  opts = opts
 parseArgs ("--dhtkey":k:args) opts = parseArgs args opts
     { dhtkey = decodeSecret $ B.pack k }
+parseArgs ("--dht-key":k:args) opts = parseArgs args opts
+    { dhtkey = decodeSecret $ B.pack k }
 parseArgs ("-4":args) opts         = parseArgs args opts
     { ip6bt  = False
     , ip6tox = False }
@@ -1053,7 +1059,9 @@ newXmmpSink session@(Tox.NCrypto { ncOutgoingQueue, ncPacketQueue }) = C.awaitFo
 -- XMPP roster.
 toxman :: Tox.Tox -> ToxManager ConnectionKey
 toxman tox = ToxManager
-    { activateAccount        = \k pubname seckey -> atomically $ do
+    { activateAccount        = \k pubname seckey -> do
+        hPutStrLn stderr $ "toxman ACTIVATE " ++ show (Tox.key2id $ toPublic seckey)
+        atomically $ do
         let ContactInfo{ accounts } = Tox.toxContactInfo tox
             pub = toPublic seckey
             pubid = Tox.key2id pub
@@ -1062,6 +1070,7 @@ toxman tox = ToxManager
             acnt <- maybe (newAccount seckey) return macnt
             rs <- readTVar $ clientRefs acnt
             writeTVar (clientRefs acnt) $! Set.insert k rs
+            modifyTVar accounts (HashMap.insert pubid acnt)
             return rs
         when (Set.null refs) $ do
             -- Schedule recurring announce.
@@ -1082,7 +1091,9 @@ toxman tox = ToxManager
             --   If this is the last reference to a non-connected contact:
             --      Stop the recurring search for that contact
             return ()
-    , setToxConnectionPolicy = \me them -> \case
+    , setToxConnectionPolicy = \me them p -> do
+       hPutStrLn stderr $ "toxman ConnectionPolicy " ++ show (me,them,p)
+       case p of
         TryingToConnect -> do
             let db@ContactInfo{ accounts } = Tox.toxContactInfo tox
             sequence_ $ do