From eaaf761dfb6af3673d9f064a791afadbbdc60e29 Mon Sep 17 00:00:00 2001 From: joe Date: Sun, 19 Nov 2017 22:59:49 -0500 Subject: Conduit stubs to convert between Tox and XMPP messages. --- Presence/XMPPServer.hs | 5 ++++ ToxToXMPP.hs | 11 ++++++++ examples/dhtd.hs | 38 +++++++++++++++++++++++----- src/Network/Tox.hs | 68 +++++++++++++++++++++++++++++++++----------------- 4 files changed, 93 insertions(+), 29 deletions(-) create mode 100644 ToxToXMPP.hs diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs index c81cb9ce..6d6d3bd7 100644 --- a/Presence/XMPPServer.hs +++ b/Presence/XMPPServer.hs @@ -9,6 +9,7 @@ module XMPPServer , XMPPServerParameters(..) , XMPPServer , xmppConnections + , xmppEventChannel , StanzaWrap(..) , Stanza(..) , StanzaType(..) @@ -27,6 +28,7 @@ module XMPPServer , makeMessage , JabberShow(..) , Server + , flushPassThrough ) where import ConnectionKey @@ -1804,6 +1806,9 @@ xmppConnections sv = tcpManager (grokPeer sv) (Just . Text.pack) resolvPeer (_xm resolvPeer :: Text -> IO (Maybe ConnectionKey) resolvPeer str = fmap PeerKey <$> listToMaybe <$> resolvePeer str +xmppEventChannel :: XMPPServer -> TChan ((ConnectionKey, SockAddr), ConnectionEvent Event) +xmppEventChannel sv = serverEvent $ _xmpp_sv sv + xmppServer :: ( MonadResource m , MonadIO m ) => XMPPServerParameters -> m XMPPServer diff --git a/ToxToXMPP.hs b/ToxToXMPP.hs new file mode 100644 index 00000000..b018e47b --- /dev/null +++ b/ToxToXMPP.hs @@ -0,0 +1,11 @@ +module ToxToXMPP where + +import Data.Conduit as C +import Data.XML.Types as XML +import Network.Tox.Crypto.Transport as Tox + +xmppToTox :: Conduit XML.Event IO Tox.CryptoMessage +xmppToTox = _todo + +toxToXmpp :: Conduit Tox.CryptoMessage IO XML.Event +toxToXmpp = _todo diff --git a/examples/dhtd.hs b/examples/dhtd.hs index e9b365cb..527af7e7 100644 --- a/examples/dhtd.hs +++ b/examples/dhtd.hs @@ -27,6 +27,7 @@ import Control.Monad.Trans.Control import Control.Monad.Trans.Resource (runResourceT) import Data.Bool import Data.Char +import Data.Conduit as C import Data.Function import Data.Hashable import Data.List @@ -35,6 +36,7 @@ import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Set as Set import Data.Time.Clock +import qualified Data.XML.Types as XML import GHC.Conc (threadStatus,ThreadStatus(..)) import GHC.Stats import Network.Socket @@ -85,6 +87,7 @@ import qualified Network.Tox.DHT.Transport as Tox import qualified Network.Tox.DHT.Handlers as Tox import qualified Network.Tox.Onion.Transport as Tox import qualified Network.Tox.Onion.Handlers as Tox +import qualified Network.Tox.Crypto.Transport as Tox (CryptoMessage) import qualified Network.Tox.Crypto.Handlers as Tox import Data.Typeable import Roster @@ -95,6 +98,8 @@ import ConsoleWriter import Presence import XMPPServer import Connection +import ToxToXMPP +import qualified Server (ConnectionEvent(..)) showReport :: [(String,String)] -> String @@ -982,6 +987,22 @@ noArgPing :: (x -> IO (Maybe r)) -> [String] -> x -> IO (Maybe r) noArgPing f [] x = f x noArgPing _ _ _ = return Nothing +announceToxConnection :: TChan ((ConnectionKey,SockAddr), Server.ConnectionEvent XML.Event) + -> SockAddr + -> SockAddr + -> STM Bool + -> C.Source IO Tox.CryptoMessage + -> C.Sink (Flush Tox.CryptoMessage) IO () + -> IO () +announceToxConnection echan laddr saddr pingflag tsrc tsnk + = atomically $ writeTChan echan + ( (PeerKey saddr, laddr ) + , Server.Connection pingflag xsrc xsnk ) + where + xsrc = tsrc =$= toxToXmpp + xsnk = flushPassThrough xmppToTox =$= tsnk + + main :: IO () main = runResourceT $ liftBaseWith $ \resT -> do args <- getArgs @@ -1007,7 +1028,12 @@ main = runResourceT $ liftBaseWith $ \resT -> do -- 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 + 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 [],[]) @@ -1106,7 +1132,11 @@ main = runResourceT $ liftBaseWith $ \resT -> do toxport -> do addrTox <- getBindAddress toxport (ip6tox opts) hPutStrLn stderr $ "Supplied key: " ++ show (fmap (Tox.key2id . toPublic) (dhtkey opts)) - tox <- Tox.newTox keysdb addrTox (Just netCryptoSessionsState) (dhtkey opts) + tox <- Tox.newTox keysdb + addrTox + (Just netCryptoSessionsState) + (dhtkey opts) + (announceToxConnection (xmppEventChannel sv) addrTox) (quitTox, toxStrap4, toxStrap6) <- Tox.forkTox tox toxSearches <- atomically $ newTVar Map.empty @@ -1329,10 +1359,6 @@ main = runResourceT $ liftBaseWith $ \resT -> do bootstrap btSaved fallbackNodes return () - atomically $ do - putTMVar serverVar (sv,conns) -- Okay, now it's ready. :) - -- FIXME: This is error prone. - forkIO $ do myThreadId >>= flip labelThread "XMPP.stanzas" let console = cwPresenceChan <$> consoleWriter state diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs index 37802e3c..5b30a7e6 100644 --- a/src/Network/Tox.hs +++ b/src/Network/Tox.hs @@ -46,6 +46,7 @@ import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Char8 as C8 import Data.ByteString.Lazy (toStrict) import Data.Char +import Data.Conduit (Source,Sink,Flush(..)) import Data.Data import Data.Functor.Contravariant import Data.Hashable @@ -85,11 +86,12 @@ import Control.TriadCommittee import Network.BitTorrent.DHT.Token as Token import GHC.TypeLits +import Connection import Crypto.Tox import Data.Word64Map (fitsInInt) import qualified Data.Word64Map (empty) import Network.Kademlia.Bootstrap (forkPollForRefresh, bootstrap) -import Network.Tox.Crypto.Transport (NetCrypto) +import Network.Tox.Crypto.Transport (NetCrypto, CryptoMessage) import Network.Tox.Crypto.Handlers (cryptoNetHandler, newSessionsState, defaultUnRecHook, defaultCryptoDataHooks, NetCryptoSessions(..)) import qualified Network.Tox.DHT.Handlers as DHT import qualified Network.Tox.DHT.Transport as DHT @@ -221,18 +223,22 @@ newClient drg net classify selfAddr handlers modifytbl modifynet = do in client return $ either mkclient mkclient tblvar handlers +data ConnectionKey -- TODO +data ConnectionStatus -- TODO + data Tox = Tox - { toxDHT :: DHT.Client - , toxOnion :: Onion.Client RouteId - , toxToRoute :: Transport String Onion.AnnouncedRendezvous (PublicKey,Onion.OnionData) - , toxCrypto :: Transport String SockAddr NetCrypto + { toxDHT :: DHT.Client + , toxOnion :: Onion.Client RouteId + , toxToRoute :: Transport String Onion.AnnouncedRendezvous (PublicKey,Onion.OnionData) + , toxCrypto :: Transport String SockAddr NetCrypto , toxCryptoSessions :: NetCryptoSessions - , toxCryptoKeys :: TransportCrypto - , toxRouting :: DHT.Routing - , toxTokens :: TVar SessionTokens - , toxAnnouncedKeys :: TVar Onion.AnnouncedKeys - , toxOnionRoutes :: OnionRouter - , toxRoster :: Roster + , toxCryptoKeys :: TransportCrypto + , toxRouting :: DHT.Routing + , toxTokens :: TVar SessionTokens + , toxAnnouncedKeys :: TVar Onion.AnnouncedKeys + , toxOnionRoutes :: OnionRouter + , toxRoster :: Roster + , toxManager :: Connection.Manager ConnectionStatus ConnectionKey } getContactInfo :: Tox -> IO DHT.DHTPublicKey @@ -289,8 +295,17 @@ getOnionAlias crypto dhtself remoteNode = atomically $ do return $ Onion.OnionDestination Onion.SearchingAlias alias Nothing -newTox :: TVar Onion.AnnouncedKeys -> SockAddr -> Maybe NetCryptoSessions -> Maybe SecretKey -> IO Tox -newTox keydb addr mbSessionsState suppliedDHTKey = do +newTox :: TVar Onion.AnnouncedKeys -- ^ Store of announced keys we are a rendezvous for. + -> SockAddr -- ^ Bind-address to listen on. + -> Maybe NetCryptoSessions -- ^ State of all one-on-one Tox links. + -> Maybe SecretKey -- ^ Optional DHT secret key to use. + -> ( SockAddr -- ^ Address of remote peer. + -> STM Bool -- ^ True if connection requires a ping. + -> Source IO CryptoMessage -- ^ Inbound packets. + -> Sink (Flush CryptoMessage) IO () -- ^ Outbound packets. + -> IO () ) -- ^ Action to invoke on new connections. + -> IO Tox +newTox keydb addr mbSessionsState suppliedDHTKey announceConnection = do udp <- {- addVerbosity <$> -} udpTransport addr (crypto0,sessionsState) <- case mbSessionsState of Nothing -> do @@ -338,17 +353,24 @@ newTox keydb addr mbSessionsState suppliedDHTKey = do roster <- newRoster return Tox - { toxDHT = dhtclient - , toxOnion = onionclient - , toxToRoute = onInbound (updateRoster roster) dtacrypt - , toxCrypto = addHandler (hPutStrLn stderr) (cryptoNetHandler sessionsState) cryptonet + { toxDHT = dhtclient + , toxOnion = onionclient + , toxToRoute = onInbound (updateRoster roster) dtacrypt + , toxCrypto = addHandler (hPutStrLn stderr) (cryptoNetHandler sessionsState) cryptonet , toxCryptoSessions = sessionsState - , toxCryptoKeys = crypto - , toxRouting = mkrouting dhtclient - , toxTokens = toks - , toxAnnouncedKeys = keydb - , toxOnionRoutes = orouter - , toxRoster = roster + , toxCryptoKeys = crypto + , toxRouting = mkrouting dhtclient + , toxTokens = toks + , toxAnnouncedKeys = keydb + , toxOnionRoutes = orouter + , toxRoster = roster + , toxManager = Connection.Manager + { setPolicy = _todo -- k -> Policy -> IO () + , connections = _todo -- STM (Map k (Connection status)) + , stringToKey = _todo -- String -> Maybe k + , showProgress = _todo -- status -> String + , showKey = _todo -- k -> String + } } onionTimeout :: Tox -> DHT.TransactionId -> Onion.OnionDestination RouteId -> STM (Onion.OnionDestination RouteId, Int) -- cgit v1.2.3