diff options
author | Joe Crayne <joe@jerkface.net> | 2019-12-23 02:09:05 -0500 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2020-01-01 23:28:00 -0500 |
commit | af2d131e01fed76205c2c0c32a2f29bab8cceb84 (patch) | |
tree | 1332a0cdac6d3870db39662ac27260fc04c2dc21 /dht/Presence/Presence.hs | |
parent | 50e1debec25341ca66456ab14574361a2a994787 (diff) |
Create new tox key automatically + disable non-tox operation.
Diffstat (limited to 'dht/Presence/Presence.hs')
-rw-r--r-- | dht/Presence/Presence.hs | 125 |
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 | |||
17 | import Control.Monad.Trans | 17 | import Control.Monad.Trans |
18 | import Network.Socket ( SockAddr(..) ) | 18 | import Network.Socket ( SockAddr(..) ) |
19 | import Data.Char | 19 | import Data.Char |
20 | import Data.List (nub, (\\), intersect, groupBy, sort, sortBy ) | 20 | import Data.List (nub, (\\), intersect, groupBy, sort, sortBy, isSuffixOf ) |
21 | import Data.Ord (comparing ) | 21 | import Data.Ord (comparing ) |
22 | import Data.Monoid ((<>)) | 22 | import Data.Monoid ((<>)) |
23 | import qualified Data.Text as Text | 23 | import qualified Data.Text as Text |
@@ -33,7 +33,7 @@ import qualified ConfigFiles | |||
33 | import Data.Maybe | 33 | import Data.Maybe |
34 | import Data.Bits | 34 | import Data.Bits |
35 | import Data.Int (Int8) | 35 | import Data.Int (Int8) |
36 | import Data.XML.Types (Event) | 36 | import Data.XML.Types as XML (Event, Name) |
37 | import System.Posix.Types (UserID,CPid) | 37 | import System.Posix.Types (UserID,CPid) |
38 | import Control.Applicative | 38 | import Control.Applicative |
39 | import Crypto.PubKey.Curve25519 (SecretKey,toPublic) | 39 | import Crypto.PubKey.Curve25519 (SecretKey,toPublic) |
@@ -51,7 +51,7 @@ import Util | |||
51 | import qualified Connection | 51 | import qualified Connection |
52 | ;import Connection (PeerAddress (..), resolvePeer, reverseAddress) | 52 | ;import Connection (PeerAddress (..), resolvePeer, reverseAddress) |
53 | import Network.Tox.NodeId (key2id,parseNoSpamId,nospam64,NoSpamId(..),ToxProgress,ToxContact(..)) | 53 | import Network.Tox.NodeId (key2id,parseNoSpamId,nospam64,NoSpamId(..),ToxProgress,ToxContact(..)) |
54 | import Crypto.Tox (decodeSecret) | 54 | import Crypto.Tox (decodeSecret,encodeSecret, generateSecretKey) |
55 | import DPut | 55 | import DPut |
56 | import DebugTag | 56 | import DebugTag |
57 | import Codec.AsciiKey256 | 57 | import Codec.AsciiKey256 |
@@ -242,67 +242,97 @@ identifyTTY' ttypids uid inode = ttypid | |||
242 | ttypid = fmap textify $ identifyTTY ttypids' uid inode | 242 | ttypid = fmap textify $ identifyTTY ttypids' uid inode |
243 | textify (tty,pid) = (fmap lazyByteStringToText tty, pid) | 243 | textify (tty,pid) = (fmap lazyByteStringToText tty, pid) |
244 | 244 | ||
245 | chooseResourceName :: PresenceState stat | 245 | |
246 | -> ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO Text | 246 | generateToxProfile :: Text -> IO ConfigFiles.Profile |
247 | chooseResourceName state k (Remote addr) clientsNameForMe desired = do | 247 | generateToxProfile user0 = do |
248 | muid <- getLocalPeerCred' addr | 248 | secret <- generateSecretKey |
249 | (mtty,pid) <- getTTYandPID muid | 249 | let pubkey = show $ key2id $ toPublic secret |
250 | user <- getJabberUserForId muid | 250 | Just s = L.fromStrict <$> encodeSecret secret |
251 | status <- atomically $ newTVar Nothing | 251 | profile = pubkey ++ ".tox" |
252 | flgs <- atomically $ newTVar 0 | 252 | user = L.fromChunks [Text.encodeUtf8 user0] |
253 | profile <- fmap (fromMaybe ".") | 253 | ConfigFiles.configPath user profile ConfigFiles.secretsFile >>= ConfigFiles.addItem s "<? secret ?>" |
254 | $ forM ((,) <$> clientsNameForMe <*> toxManager state) $ \(wanted_profile0,toxman) -> | 254 | dput XMisc $ "Generated new Tox key " ++ profile |
255 | case stripSuffix ".tox" wanted_profile0 of | 255 | return profile |
256 | Just "*" -> do | 256 | |
257 | dput XMisc $ "TODO: Match single tox key profile or generate first." | 257 | |
258 | -- TODO: Match single tox key profile or generate first. | 258 | autoSelectToxProfile :: Text -> IO (Maybe ConfigFiles.Profile) |
259 | _todo | 259 | autoSelectToxProfile user = do |
260 | ps <- filter (isSuffixOf ".tox") <$> ConfigFiles.getProfiles (L.fromChunks [Text.encodeUtf8 user]) | ||
261 | case ps of | ||
262 | [profile] -> return $ Just profile | ||
263 | [] -> Just <$> generateToxProfile user | ||
264 | _ -> return Nothing | ||
265 | |||
266 | chooseProfile :: Text -> Bool -> ClientAddress -> Maybe (Text, ToxManager ClientAddress) -> IO (Either Text ConfigFiles.Profile) | ||
267 | chooseProfile user allowNonTox k wanted_profile0 = do | ||
268 | let doAuto = do | ||
269 | p <- autoSelectToxProfile user | ||
270 | case p of Nothing -> return $ Left "Tox user-id is ambiguous." | ||
271 | Just pr -> chooseProfile user allowNonTox k | ||
272 | (Just (Text.pack pr, snd $ fromJust wanted_profile0)) | ||
273 | case stripSuffix ".tox" =<< fmap fst wanted_profile0 of | ||
274 | Just "auto" -> doAuto | ||
260 | Just pub -> do | 275 | Just pub -> do |
261 | cdir <- ConfigFiles.configPath (L.fromChunks [Text.encodeUtf8 user]) "." "" | 276 | cdir <- ConfigFiles.configPath (L.fromChunks [Text.encodeUtf8 user]) "." "" |
262 | #if !MIN_VERSION_directory(1,2,5) | ||
263 | let listDirectory path = filter (`notElem` [".",".."]) <$> getDirectoryContents path | ||
264 | #endif | ||
265 | cfs <- map Text.pack <$> listDirectory cdir `catchIOError` (\e -> return []) | 277 | cfs <- map Text.pack <$> listDirectory cdir `catchIOError` (\e -> return []) |
266 | let profiles = filter (\f -> Text.toLower f == Text.toLower wanted_profile0) cfs | 278 | let Just (wanted_profile1,toxman) = wanted_profile0 |
279 | profiles = filter (\f -> Text.toLower f == Text.toLower wanted_profile1) cfs | ||
267 | -- dput XMisc $ "Toxmpp profile " ++ show (user,wanted_profile0,profiles,cfs) | 280 | -- dput XMisc $ "Toxmpp profile " ++ show (user,wanted_profile0,profiles,cfs) |
268 | let wanted_profile = head $ profiles ++ [wanted_profile0] | 281 | let wanted_profile = head $ profiles ++ [wanted_profile1] |
269 | secs <- configText ConfigFiles.getSecrets user wanted_profile | 282 | secs <- configText ConfigFiles.getSecrets user wanted_profile |
270 | case secs of | 283 | case secs of |
271 | sec:_ | Just s <- decodeSecret (Text.encodeUtf8 sec) | 284 | sec:_ | Just s <- decodeSecret (Text.encodeUtf8 sec) |
272 | , map toLower (show $ key2id $ toPublic s) == map toLower (Text.unpack pub) | 285 | , map toLower (show $ key2id $ toPublic s) == map toLower (Text.unpack pub) |
273 | -> do activateAccount toxman k wanted_profile s | 286 | -> do activateAccount toxman k wanted_profile s |
274 | dput XMisc $ "loaded tox secret " ++ show sec | 287 | dput XMisc $ "loaded tox secret " ++ show sec |
275 | return wanted_profile | 288 | return $ Right $ Text.unpack wanted_profile |
276 | _ -> do | 289 | _ -> do |
277 | -- XXX: We should probably fail to connect when an | 290 | -- XXX: We should probably fail to connect when an |
278 | -- invalid Tox profile is used. For now, we'll | 291 | -- invalid Tox profile is used. For now, we'll |
279 | -- fall back to the Unix account login. | 292 | -- fall back to the Unix account login. |
280 | dput XMisc "failed to find tox secret" | 293 | dput XMisc "failed to find tox secret" |
281 | return "." | 294 | return $ Left $ "Missing secret key for " <> pub |
282 | _ -> return "." | 295 | Nothing | allowNonTox -> return $ Right "." |
283 | let client = ClientState { clientResource = maybe "fallback" id mtty | 296 | | otherwise -> doAuto |
284 | , clientUser = user | ||
285 | , clientProfile = profile | ||
286 | , clientPid = pid | ||
287 | , clientStatus = status | ||
288 | , clientFlags = flgs } | ||
289 | |||
290 | do -- forward-lookup of the buddies so that it is cached for reversing. | ||
291 | buds <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client) | ||
292 | forM_ buds $ \bud -> do | ||
293 | let (_,h,_) = splitJID bud | ||
294 | forkLabeled "XMPP.buddies.resolvePeer" $ do | ||
295 | void $ resolvePeer (manager state $ clientProfile client) h | ||
296 | 297 | ||
297 | atomically $ do | 298 | chooseResourceName :: PresenceState stat |
298 | modifyTVar' (clients state) $ Map.insert k client | 299 | -> ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO (Either Text Text) |
299 | let add mb = Just $ maybe (pcSingletonNetworkClient k client) | 300 | chooseResourceName state k (Remote addr) clientsNameForMe desired = do |
300 | (pcInsertNetworkClient k client) | 301 | muid <- getLocalPeerCred' addr |
301 | mb | 302 | (mtty,pid) <- getTTYandPID muid |
302 | modifyTVar' (clientsByUser state) $ Map.alter add (clientUser client) | 303 | user <- getJabberUserForId muid |
303 | modifyTVar' (clientsByProfile state) $ Map.alter add (clientProfile client) | 304 | status <- atomically $ newTVar Nothing |
305 | flgs <- atomically $ newTVar 0 | ||
306 | let mprofspec = (,) <$> clientsNameForMe <*> toxManager state | ||
307 | eprofile <- chooseProfile user False k mprofspec | ||
308 | case eprofile of | ||
309 | |||
310 | Right profile -> do | ||
311 | let client = ClientState { clientResource = maybe "fallback" id mtty | ||
312 | , clientUser = user | ||
313 | , clientProfile = Text.pack profile | ||
314 | , clientPid = pid | ||
315 | , clientStatus = status | ||
316 | , clientFlags = flgs } | ||
317 | |||
318 | do -- forward-lookup of the buddies so that it is cached for reversing. | ||
319 | buds <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client) | ||
320 | forM_ buds $ \bud -> do | ||
321 | let (_,h,_) = splitJID bud | ||
322 | forkLabeled "XMPP.buddies.resolvePeer" $ do | ||
323 | void $ resolvePeer (manager state $ clientProfile client) h | ||
324 | |||
325 | atomically $ do | ||
326 | modifyTVar' (clients state) $ Map.insert k client | ||
327 | let add mb = Just $ maybe (pcSingletonNetworkClient k client) | ||
328 | (pcInsertNetworkClient k client) | ||
329 | mb | ||
330 | modifyTVar' (clientsByUser state) $ Map.alter add (clientUser client) | ||
331 | modifyTVar' (clientsByProfile state) $ Map.alter add (clientProfile client) | ||
332 | |||
333 | Right <$> localJID (clientUser client) (clientProfile client) (clientResource client) | ||
304 | 334 | ||
305 | localJID (clientUser client) (clientProfile client) (clientResource client) | 335 | Left e -> return $ Left e |
306 | 336 | ||
307 | where | 337 | where |
308 | getTTYandPID muid = do | 338 | getTTYandPID muid = do |
@@ -1294,6 +1324,7 @@ peerSubscriptionRequest state fail k stanza chan = do | |||
1294 | , stanzaTo = Just $ unsplitJID totup } | 1324 | , stanzaTo = Just $ unsplitJID totup } |
1295 | chan | 1325 | chan |
1296 | 1326 | ||
1327 | myMakeRosterUpdate :: Text -> Text -> Text -> [(XML.Name, Text)] -> IO Stanza | ||
1297 | myMakeRosterUpdate prf tojid contact as | 1328 | myMakeRosterUpdate prf tojid contact as |
1298 | | ".tox" `Text.isSuffixOf` prf | 1329 | | ".tox" `Text.isSuffixOf` prf |
1299 | , (Just u,h,r) <- splitJID contact | 1330 | , (Just u,h,r) <- splitJID contact |