Create new tox key automatically + disable non-tox operation.

4 files changed, 121 insertions, 83 deletions

diff --git a/dht/Presence/ConfigFiles.hs b/dht/Presence/ConfigFiles.hs
index d0164e33..e88989f2 100644
--- a/dht/Presence/ConfigFiles.hs
+++ b/dht/Presence/ConfigFiles.hs
@@ -59,7 +59,7 @@ createConfigFile :: ByteString -> FilePath -> IO ()
 createConfigFile tag path = do
     let dir = dropFileName path
     doesDirectoryExist dir >>= flip unless (do
-            createDirectory dir
+            createDirectoryIfMissing True dir
         )
     withFile path WriteMode $ \h -> do
         L.hPutStrLn h tag
@@ -79,6 +79,16 @@ addItem item tag path =
     in doit
 
 
+getProfiles :: User -> IO [Profile]
+getProfiles user = do
+    home <- homeDirectory <$> getUserEntryForName (unpack user)
+    let cfg = home </> configDir
+    fs <- listDirectory cfg
+    ds <- filterM (doesDirectoryExist . (cfg </>))  fs
+    return ds
+  `catchIOError` \e -> do
+    return []
+
 -- | Modify a presence configuration file.  This function will iterate over all
 -- items in the file and invoke a test function.  If the function returns
 -- Nothing, that item is removed from the file.  Otherwise, the function may
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
diff --git a/dht/Presence/XMPPServer.hs b/dht/Presence/XMPPServer.hs
index 2f2a1b4b..65d882bd 100644
--- a/dht/Presence/XMPPServer.hs
+++ b/dht/Presence/XMPPServer.hs
@@ -124,9 +124,11 @@ data XMPPServerParameters =
       --   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
+      -- The returned domain will be discarded and replaced with the result of
       -- 'xmppTellMyNameToClient'.
-      xmppChooseResourceName :: ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO Text
+      --
+      -- A Left result causes an error stanza to be sent instead.
+      xmppChooseResourceName :: ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO (Either Text Text)
     , -- | This should indicate the server's hostname that all client's see.
       xmppTellMyNameToClient :: ClientAddress -> IO Text
     , xmppTellMyNameToPeer   :: Local SockAddr -> IO Text
@@ -1436,6 +1438,17 @@ lookupService me mucs to = case Text.toLower to of
                     Nothing  -> UnknownService service
     _ -> NotMe
 
+requestVersion :: Text -> Text -> ConduitT i XML.Event IO ()
+requestVersion rsc hostname = do
+    yield $ EventBeginElement "{jabber:client}iq"
+        [ attr "to" rsc
+        , attr "from" hostname
+        , attr "type" "get"
+        , attr "id" "version"]
+    yield $ EventBeginElement "{jabber:iq:version}query" []
+    yield $ EventEndElement "{jabber:iq:version}query"
+    yield $ EventEndElement "{jabber:client}iq"
+
 applyStanza :: Server PeerAddress ConnectionData releaseKey Event
                      -> TVar (Map.Map ClientAddress (Map.Map (Text,Text) (TChan Stanza,JoinedRoom ClientAddress)))
                      -> TMVar ()
@@ -1450,38 +1463,22 @@ applyStanza sv joined_rooms quitVar xmpp stanza = do
         case stanzaType stanza of
             RequestResource clientsNameForMe wanted -> do
                 sockaddr <- socketFromKey sv k
-                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
-                let requestVersion :: ConduitT i XML.Event IO ()
-                    requestVersion = do
-                      yield $ EventBeginElement "{jabber:client}iq"
-                                  [ attr "to" rsc
-                                  , attr "from" hostname
-                                  , attr "type" "get"
-                                  , attr "id" "version"]
-                      yield $ EventBeginElement "{jabber:iq:version}query" []
-                      yield $ EventEndElement "{jabber:iq:version}query"
-                      yield $ EventEndElement "{jabber:client}iq"
-                      {-
-                      -- XXX Debug chat:
-                      yield $ EventBeginElement "{jabber:client}message"
-                              [ attr "from" $ eventContent (Just [ContentText rsc])
-                              , attr "type" "normal" ] -- "blackbird" ]
-                      yield $ EventBeginElement "{jabber:client}body" []
-                      yield $ EventContent $ ContentText ("hello?")
-                      yield $ EventEndElement "{jabber:client}body"
-                      yield $ EventEndElement "{jabber:client}message"
-                      -}
-                sendReply quitVar SetResource reply replyto
-                conduitToStanza (UnrecognizedQuery "{jabber:iq:version}query")
-                      Nothing -- id
-                      (Just hostname) -- from
-                      (Just rsc) -- to
-                      requestVersion
-                  >>= ioWriteChan replyto
+                xmppChooseResourceName xmpp k sockaddr clientsNameForMe wanted >>= \case
+                    Right rsc0 -> do
+                        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
+                        conduitToStanza (UnrecognizedQuery "{jabber:iq:version}query")
+                              Nothing -- id
+                              (Just hostname) -- from
+                              (Just rsc) -- to
+                              (requestVersion rsc hostname)
+                          >>= ioWriteChan replyto
+                    Left err -> do
+                        hostname <- xmppTellMyNameToClient xmpp k
+                        reply <- makeErrorStanza' stanza NotAllowed []
+                        sendReply quitVar (Error NotAuthorized (head reply)) reply replyto
             SessionRequest -> do
                 me <- xmppTellMyNameToClient xmpp k
                 let reply = iq_session_reply (stanzaId stanza) me
diff --git a/dht/dht-client.cabal b/dht/dht-client.cabal
index 5b75d8a8..64d48f53 100644
--- a/dht/dht-client.cabal
+++ b/dht/dht-client.cabal
@@ -66,7 +66,7 @@ custom-setup
   setup-depends:
     base  >= 4.5,
     Cabal >= 1.14,
-    directory
+    directory >= 1.2.5
 
 library
   default-language:    Haskell2010