1 files changed, 78 insertions, 47 deletions

diff --git a/dht/Presence/Presence.hs b/dht/Presence/Presence.hs
index 926ee3c2..b8c9f923 100644
--- a/dht/Presence/Presence.hs
+++ b/dht/Presence/Presence.hs
@@ -17,7 +17,7 @@ import Control.Concurrent.STM
 import Control.Monad.Trans
 import Network.Socket ( SockAddr(..) )
 import Data.Char
-import Data.List (nub, (\\), intersect, groupBy, sort, sortBy )
+import Data.List (nub, (\\), intersect, groupBy, sort, sortBy, isSuffixOf )
 import Data.Ord (comparing )
 import Data.Monoid ((<>))
 import qualified Data.Text as Text
@@ -33,7 +33,7 @@ import qualified ConfigFiles
 import Data.Maybe
 import Data.Bits
 import Data.Int (Int8)
-import Data.XML.Types (Event)
+import Data.XML.Types as XML (Event, Name)
 import System.Posix.Types (UserID,CPid)
 import Control.Applicative
 import Crypto.PubKey.Curve25519 (SecretKey,toPublic)
@@ -51,7 +51,7 @@ import Util
 import qualified Connection
          ;import Connection (PeerAddress (..), resolvePeer, reverseAddress)
 import Network.Tox.NodeId (key2id,parseNoSpamId,nospam64,NoSpamId(..),ToxProgress,ToxContact(..))
-import Crypto.Tox (decodeSecret)
+import Crypto.Tox (decodeSecret,encodeSecret, generateSecretKey)
 import DPut
 import DebugTag
 import Codec.AsciiKey256
@@ -242,67 +242,97 @@ identifyTTY' ttypids uid inode = ttypid
        ttypid = fmap textify $ identifyTTY ttypids' uid inode
        textify (tty,pid) = (fmap lazyByteStringToText tty, pid)
 
-chooseResourceName :: PresenceState stat
-                    -> ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO Text
-chooseResourceName state k (Remote addr) clientsNameForMe desired = do
-    muid <- getLocalPeerCred' addr
-    (mtty,pid) <- getTTYandPID muid
-    user <- getJabberUserForId muid
-    status <- atomically $ newTVar Nothing
-    flgs <- atomically $ newTVar 0
-    profile <- fmap (fromMaybe ".")
-        $ forM ((,) <$> clientsNameForMe <*> toxManager state) $ \(wanted_profile0,toxman) ->
-        case stripSuffix ".tox" wanted_profile0 of
-            Just "*" -> do
-                dput XMisc $ "TODO: Match single tox key profile or generate first."
-                -- TODO: Match single tox key profile or generate first.
-                _todo
+
+generateToxProfile :: Text -> IO ConfigFiles.Profile
+generateToxProfile user0 = do
+    secret <- generateSecretKey
+    let pubkey = show $ key2id $ toPublic secret
+        Just s = L.fromStrict <$> encodeSecret secret
+        profile = pubkey ++ ".tox"
+        user = L.fromChunks [Text.encodeUtf8 user0]
+    ConfigFiles.configPath user profile ConfigFiles.secretsFile >>= ConfigFiles.addItem s "<? secret ?>"
+    dput XMisc $ "Generated new Tox key " ++ profile
+    return profile
+
+
+autoSelectToxProfile :: Text -> IO (Maybe ConfigFiles.Profile)
+autoSelectToxProfile user = do
+    ps <- filter (isSuffixOf ".tox") <$> ConfigFiles.getProfiles (L.fromChunks [Text.encodeUtf8 user])
+    case ps of
+        [profile] -> return $ Just profile
+        []        -> Just <$> generateToxProfile user
+        _         -> return Nothing
+
+chooseProfile :: Text -> Bool -> ClientAddress -> Maybe (Text, ToxManager ClientAddress) -> IO (Either Text ConfigFiles.Profile)
+chooseProfile user allowNonTox k wanted_profile0 = do
+        let doAuto = do
+                p <- autoSelectToxProfile user
+                case p of Nothing -> return $ Left "Tox user-id is ambiguous."
+                          Just pr -> chooseProfile user allowNonTox k
+                                        (Just (Text.pack pr, snd $ fromJust wanted_profile0))
+        case stripSuffix ".tox" =<< fmap fst wanted_profile0 of
+            Just "auto" -> doAuto
             Just pub -> do
                 cdir <- ConfigFiles.configPath (L.fromChunks [Text.encodeUtf8 user]) "." ""
-#if !MIN_VERSION_directory(1,2,5)
-                let listDirectory path = filter (`notElem` [".",".."]) <$> getDirectoryContents path
-#endif
                 cfs  <- map Text.pack <$> listDirectory cdir `catchIOError` (\e -> return [])
-                let profiles = filter (\f -> Text.toLower f == Text.toLower wanted_profile0) cfs
+                let Just (wanted_profile1,toxman) = wanted_profile0
+                    profiles = filter (\f -> Text.toLower f == Text.toLower wanted_profile1) cfs
                 -- dput XMisc $ "Toxmpp profile " ++ show (user,wanted_profile0,profiles,cfs)
-                let wanted_profile = head $ profiles ++ [wanted_profile0]
+                let wanted_profile = head $ profiles ++ [wanted_profile1]
                 secs <- configText ConfigFiles.getSecrets user wanted_profile
                 case secs of
                     sec:_ | Just s <- decodeSecret (Text.encodeUtf8 sec)
                           , map toLower (show $ key2id $ toPublic s) == map toLower (Text.unpack pub)
                           -> do activateAccount toxman k wanted_profile s
                                 dput XMisc $ "loaded tox secret " ++ show sec
-                                return wanted_profile
+                                return $ Right $ Text.unpack 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.
                             dput XMisc "failed to find tox secret"
-                            return "."
-            _ -> return "."
-    let client = ClientState { clientResource = maybe "fallback" id mtty
-                             , clientUser     = user
-                             , clientProfile  = profile
-                             , clientPid      = pid
-                             , clientStatus   = status
-                             , clientFlags    = flgs }
-
-    do -- forward-lookup of the buddies so that it is cached for reversing.
-       buds <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client)
-       forM_ buds $ \bud -> do
-            let (_,h,_) = splitJID bud
-            forkLabeled "XMPP.buddies.resolvePeer" $ do
-                void $ resolvePeer (manager state $ clientProfile client) h
+                            return $ Left $ "Missing secret key for " <> pub
+            Nothing | allowNonTox -> return $ Right "."
+                    | otherwise   -> doAuto
 
-    atomically $ do
-        modifyTVar' (clients state) $ Map.insert k client
-        let add mb = Just $ maybe (pcSingletonNetworkClient k client)
-                                  (pcInsertNetworkClient k client)
-                                  mb
-        modifyTVar' (clientsByUser    state) $ Map.alter add (clientUser client)
-        modifyTVar' (clientsByProfile state) $ Map.alter add (clientProfile client)
+chooseResourceName :: PresenceState stat
+                    -> ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO (Either Text Text)
+chooseResourceName state k (Remote addr) clientsNameForMe desired = do
+    muid <- getLocalPeerCred' addr
+    (mtty,pid) <- getTTYandPID muid
+    user <- getJabberUserForId muid
+    status <- atomically $ newTVar Nothing
+    flgs <- atomically $ newTVar 0
+    let mprofspec = (,) <$> clientsNameForMe <*> toxManager state
+    eprofile <- chooseProfile user False k mprofspec
+    case eprofile of
+
+        Right profile -> do
+            let client = ClientState { clientResource = maybe "fallback" id mtty
+                                     , clientUser     = user
+                                     , clientProfile  = Text.pack profile
+                                     , clientPid      = pid
+                                     , clientStatus   = status
+                                     , clientFlags    = flgs }
+
+            do -- forward-lookup of the buddies so that it is cached for reversing.
+               buds <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client)
+               forM_ buds $ \bud -> do
+                    let (_,h,_) = splitJID bud
+                    forkLabeled "XMPP.buddies.resolvePeer" $ do
+                        void $ resolvePeer (manager state $ clientProfile client) h
+
+            atomically $ do
+                modifyTVar' (clients state) $ Map.insert k client
+                let add mb = Just $ maybe (pcSingletonNetworkClient k client)
+                                          (pcInsertNetworkClient k client)
+                                          mb
+                modifyTVar' (clientsByUser    state) $ Map.alter add (clientUser client)
+                modifyTVar' (clientsByProfile state) $ Map.alter add (clientProfile client)
+
+            Right <$> localJID (clientUser client) (clientProfile client) (clientResource client)
 
-    localJID (clientUser client) (clientProfile client) (clientResource client)
+        Left e -> return $ Left e
 
   where
     getTTYandPID muid = do
@@ -1294,6 +1324,7 @@ peerSubscriptionRequest state fail k stanza chan = do
                                    , stanzaTo = Just $ unsplitJID totup }
                                chan
 
+myMakeRosterUpdate :: Text -> Text -> Text -> [(XML.Name, Text)] -> IO Stanza
 myMakeRosterUpdate prf tojid contact as
     | ".tox" `Text.isSuffixOf` prf
     , (Just u,h,r) <- splitJID contact