From 3a7055ddc6b29de004b1e94282a3fb88480d6aec Mon Sep 17 00:00:00 2001 From: joe Date: Tue, 21 Nov 2017 02:00:20 -0500 Subject: ToxManager reworked stubs. --- Presence/Presence.hs | 26 +++++++++++++++++----- examples/dhtd.hs | 63 +++++++++++++++++++++++++++++----------------------- 2 files changed, 56 insertions(+), 33 deletions(-) diff --git a/Presence/Presence.hs b/Presence/Presence.hs index 77689d1e..ed1c5033 100644 --- a/Presence/Presence.hs +++ b/Presence/Presence.hs @@ -39,7 +39,8 @@ import Data.XML.Types (Event) import System.Posix.Types (UserID,CPid) import Control.Applicative import Crypto.Error.Types (CryptoFailable (..)) -import Crypto.PubKey.Curve25519 (publicKey, secretKey, toPublic) +import Crypto.PubKey.Curve25519 (SecretKey,toPublic) +import Text.Read (readMaybe) import LockedChan (LockedChan) import TraversableT @@ -51,6 +52,8 @@ import ConsoleWriter import ClientState import Util import qualified Connection +import Network.Tox.NodeId (id2key) +import Crypto.Tox (decodeSecret) isPeerKey :: ConnectionKey -> Bool isPeerKey k = case k of { PeerKey {} -> True ; _ -> False } @@ -65,9 +68,22 @@ localJID user "." resource = do localJID user profile resource = return $ user <> "@" <> profile <> "/" <> resource +-- | These hooks will be invoked in order to connect to *.tox hosts in the +-- user's roster. +-- +-- The parameter k is a lookup key corresponding to an XMPP client. Each +-- unique value should be able to hold a reference to the ToxID identity which +-- should stay online until all interested keys have run 'deactivateAccount'. data ToxManager k = ToxManager - { activateAccount :: k -> Text -> IO () + -- | Put the given ToxID online. + { activateAccount :: k -> Text -> SecretKey -> IO () + -- | Take the given ToxID offline (assuming no other /k/ has a claim). , deactivateAccount :: k -> Text -> IO () + -- | Try to connect to the remote peer (or not). + -- + -- The arguments are our public key (in hostname format) followed by + -- their public key (in hostname format) and the Policy to set for this + -- link. , setToxConnectionPolicy :: Text -> Text -> Connection.Policy -> IO () } @@ -196,9 +212,9 @@ chooseResourceName state k addr clientsNameForMe desired = do -- TODO: Tox key profile. secs <- configText ConfigFiles.getSecrets user wanted_profile case secs of - sec:_ | CryptoPassed s <- secretKey (Text.encodeUtf8 sec) - , CryptoPassed (toPublic s) == publicKey (Text.encodeUtf8 pub) - -> do activateAccount toxman k wanted_profile + sec:_ | Just s <- decodeSecret (Text.encodeUtf8 sec) + , Just (toPublic s) == fmap id2key (readMaybe $ Text.unpack pub) + -> do activateAccount toxman k wanted_profile s return wanted_profile _ -> do -- XXX: We should probably fail to connect when an diff --git a/examples/dhtd.hs b/examples/dhtd.hs index 73ae5a57..fbfca86f 100644 --- a/examples/dhtd.hs +++ b/examples/dhtd.hs @@ -994,6 +994,18 @@ newXmmpSource = _todo newXmmpSink :: Tox.NetCryptoSession -> IO (C.Sink (Flush Tox.CryptoMessage) IO ()) newXmmpSink = _todo +-- | TODO +-- +-- These hooks will be invoked in order to connect to *.tox hosts in a user's +-- XMPP roster. +toxman :: Tox.Tox -> ToxManager k +toxman tox = ToxManager + { activateAccount = \k pubname seckey -> return () + , deactivateAccount = \k pubname -> return () + , setToxConnectionPolicy = \me them policy -> return () + } + + announceToxXMPPClients :: TChan ((ConnectionKey,SockAddr), Tcp.ConnectionEvent XML.Event) -> SockAddr -> SockAddr @@ -1012,6 +1024,7 @@ announceToxXMPPClients echan laddr saddr pingflag tsrc tsnk xsnk = flushPassThrough xmppToTox =$= tsnk + main :: IO () main = runResourceT $ liftBaseWith $ \resT -> do args <- getArgs @@ -1027,28 +1040,6 @@ main = runResourceT $ liftBaseWith $ \resT -> do announcer <- forkAnnouncer - let toxman = ToxManager - { activateAccount = \k pubkey -> return () - , deactivateAccount = \k pubkey -> return () - , setToxConnectionPolicy = \me them policy -> return () - } - - -- XMPP initialization - cw <- newConsoleWriter - serverVar <- atomically $ newEmptyTMVar - state <- newPresenceState cw (Just toxman) serverVar - - -- XMPP stanza handling - sv <- resT $ xmppServer (presenceHooks state (verbosity opts)) - -- We now have a server object but it's not ready to use until - -- we put it into the 'server' field of our /state/ record. - - conns <- xmppConnections sv - - atomically $ do - putTMVar serverVar (sv,conns) -- Okay, now it's ready. :) - -- FIXME: This is error prone. - (quitBt,btdhts,btips,baddrs) <- case portbt opts of "" -> return (return (), Map.empty,return [],[]) @@ -1145,12 +1136,6 @@ main = runResourceT $ liftBaseWith $ \resT -> do "" -> return (Nothing,return (), Map.empty, return [],[]) toxport -> do addrTox <- getBindAddress toxport (ip6tox opts) - atomically $ Tox.addNewSessionHook netCryptoSessionsState $ \mbNoSpam netcrypto -> do - let Just pingMachine = Tox.ncPingMachine netcrypto - pingflag = readTVar (pingFlag pingMachine) - xmppSrc <- newXmmpSource netcrypto - xmppSink <- newXmmpSink netcrypto - announceToxXMPPClients (xmppEventChannel sv) addrTox (Tox.ncSockAddr netcrypto) pingflag xmppSrc xmppSink hPutStrLn stderr $ "Supplied key: " ++ show (fmap (Tox.key2id . toPublic) (dhtkey opts)) tox <- Tox.newTox keysdb addrTox @@ -1321,8 +1306,30 @@ main = runResourceT $ liftBaseWith $ \resT -> do ips = readExternals Tox.nodeAddr [ Tox.routing4 $ Tox.toxRouting tox , Tox.routing6 $ Tox.toxRouting tox ] return (Just tox, quitTox, dhts, ips, [addrTox]) + _ <- UPNP.requestPorts "dht-client" $ map (Datagram,) $ baddrs ++ taddrs + -- XMPP initialization + cw <- newConsoleWriter + serverVar <- atomically $ newEmptyTMVar + state <- newPresenceState cw (toxman <$> mbtox) serverVar + + sv <- resT $ xmppServer (presenceHooks state (verbosity opts)) + -- We now have a server object but it's not ready to use until + -- we put it into the 'server' field of our /state/ record. + conns <- xmppConnections sv + atomically $ do + putTMVar serverVar (sv,conns) -- Okay, now it's ready. :) + -- FIXME: This is error prone. + + forM_ (take 1 taddrs) $ \addrTox -> do + atomically $ Tox.addNewSessionHook netCryptoSessionsState $ \mbNoSpam netcrypto -> do + let Just pingMachine = Tox.ncPingMachine netcrypto + pingflag = readTVar (pingFlag pingMachine) + xmppSrc <- newXmmpSource netcrypto + xmppSink <- newXmmpSink netcrypto + announceToxXMPPClients (xmppEventChannel sv) addrTox (Tox.ncSockAddr netcrypto) pingflag xmppSrc xmppSink + let dhts = Map.union btdhts toxdhts (waitForSignal, checkQuit) <- do -- cgit v1.2.3