{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} module Network.Tox where #ifdef THREAD_DEBUG import Control.Concurrent.Lifted.Instrument #else import Control.Concurrent.Lifted #endif import Control.Arrow import Control.Concurrent.STM import Control.Exception (throwIO) import Control.Monad import Crypto.PubKey.Curve25519 import Crypto.Random import Data.Bits.ByteString () import qualified Data.ByteString as B ;import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as C8 import Data.Data import qualified Data.Dependent.Map as DMap import Data.Dependent.Sum import Data.Functor import Data.Functor.Identity import Data.Functor.Contravariant import Data.Maybe import qualified Data.MinMaxPSQ as MinMaxPSQ import qualified Data.Serialize as S import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Word import Network.Socket import System.Endian import System.IO.Error import Crypto.Tox import Data.TableMethods import qualified Data.Tox.DHT.Multi as Multi import Data.Tox.Onion (substituteLoopback) import qualified Data.Word64Map import qualified Data.Word64Map (empty) ;import Data.Word64Map (fitsInInt) import qualified Data.Wrapper.PSQ as PSQ import Network.Address (IP, WantIP (..), getBindAddress) import Network.Bind as Bind import Network.BitTorrent.DHT.Token as Token import Network.Kademlia.Bootstrap (bootstrap, forkPollForRefresh) import qualified Network.Kademlia.Routing as R import Network.QueryResponse import Network.StreamServer (ServerHandle, quitListening) import Network.Tox.Crypto.Transport (CryptoPacket, Handshake (..)) import qualified Network.Tox.DHT.Handlers as DHT import qualified Network.Tox.DHT.Transport as DHT import Network.Tox.NodeId import qualified Network.Tox.Onion.Handlers as Onion import qualified Network.Tox.Onion.Transport as Onion import Network.Tox.RelayPinger import System.Global6 import Network.Tox.Transport import Network.Tox.TCP (tcpClient, ViaRelay(..), RelayClient) import Network.Tox.Onion.Routes import Network.Tox.ContactInfo import Text.XXD import DPut import DebugTag import TCPProber import Network.Tox.Avahi import Network.Tox.Session import qualified Data.Tox.Relay as TCP import Network.Tox.Relay import Network.SessionTransports import Network.Kademlia.Search import HandshakeCache import Data.ByteString.Base16 as Base16 import qualified DBus.Client as DBus import Control.Exception updateIP :: TVar (R.BucketList NodeInfo) -> SockAddr -> STM () updateIP tblvar a = do bkts <- readTVar tblvar case nodeInfo (nodeId (R.thisNode bkts)) a of Right ni -> writeTVar tblvar (bkts { R.thisNode = ni }) Left _ -> return () genNonce24 :: DRG g => TVar (g, pending) -> DHT.TransactionId -> IO DHT.TransactionId genNonce24 var (DHT.TransactionId nonce8 _) = atomically $ do (g,pending) <- readTVar var let (bs, g') = randomBytesGenerate 24 g writeTVar var (g',pending) return $ DHT.TransactionId nonce8 (Nonce24 bs) gen :: forall gen. DRG gen => gen -> (DHT.TransactionId, gen) gen g = let (bs, g') = randomBytesGenerate 24 g (ws, g'') = randomBytesGenerate 8 g' Right w = S.runGet S.getWord64be ws in ( DHT.TransactionId (Nonce8 w) (Nonce24 bs), g'' ) intKey :: DHT.TransactionId -> Int intKey (DHT.TransactionId (Nonce8 w) _) = fromIntegral w w64Key :: DHT.TransactionId -> Word64 w64Key (DHT.TransactionId (Nonce8 w) _) = w nonceKey :: DHT.TransactionId -> Nonce8 nonceKey (DHT.TransactionId n _) = n -- | Return my own address. myAddr :: TVar (R.BucketList NodeInfo) -- ^ IPv4 buckets -> TVar (R.BucketList NodeInfo) -- ^ IPv6 buckets -> Maybe Multi.NodeInfo -- ^ Interested remote address -> IO Multi.NodeInfo myAddr routing4 routing6 maddr = atomically $ do let var = case flip DHT.prefer4or6 Nothing <$> maddr of Just Want_IP6 -> routing4 _ -> routing6 a <- readTVar var return $ Multi.UDP ==> R.thisNode a newClient :: forall g addr meth x. (DRG g, Show addr, Show meth) => g -> Transport String addr x -> (Client String meth DHT.TransactionId addr x -> x -> MessageClass String meth DHT.TransactionId addr x) -> (Maybe addr -> IO addr) -> (Client String meth DHT.TransactionId addr x -> meth -> Maybe (MethodHandler String DHT.TransactionId addr x)) -> (forall d. TransactionMethods d DHT.TransactionId addr x -> TransactionMethods d DHT.TransactionId addr x) -> (Client String meth DHT.TransactionId addr x -> Transport String addr x -> Transport String addr x) -> IO (Client String meth DHT.TransactionId addr x) newClient drg net classify selfAddr handlers modifytbl modifynet = do -- If we have 8-byte keys for IntMap, then use it for transaction lookups. -- Otherwise, use ordinary Map. The details of which will be hidden by an -- existential closure (see mkclient below). -- tblvar <- if fitsInInt (Proxy :: Proxy Word64) then do let intmapT = transactionMethods (contramap intKey intMapMethods) gen intmap_var <- atomically $ newTVar (drg, mempty) return $ Right (intmapT,intmap_var) else do let word64mapT = transactionMethods (contramap w64Key w64MapMethods) gen map_var <- atomically $ newTVar (drg, Data.Word64Map.empty) return $ Left (word64mapT,map_var) let dispatch :: TransactionMethods tbl DHT.TransactionId addr x -> p -> (meth -> Maybe (MethodHandlerA String DHT.TransactionId addr x y)) -> Client String meth DHT.TransactionId addr x -> DispatchMethodsA tbl String meth DHT.TransactionId addr x y dispatch tbl var handlers client = DispatchMethods { classifyInbound = classify client , lookupHandler = handlers -- var , tableMethods = modifytbl tbl } mkclient :: (TransactionMethods (g, pending) DHT.TransactionId addr x, TVar (g, pending)) -> (ClientA String meth DHT.TransactionId addr x x -> meth -> Maybe (MethodHandlerA String DHT.TransactionId addr x x)) -> ClientA String meth DHT.TransactionId addr x x mkclient (tbl,var) handlers = let client = Client { clientNet = addHandler (handleMessage client) $ modifynet client net , clientDispatcher = dispatch tbl var (handlers client) client , clientErrorReporter = logErrors , clientPending = var , clientAddress = selfAddr , clientResponseId = genNonce24 var } in client return $ either mkclient mkclient tblvar handlers data Tox extra = Tox { toxDHT :: DHT.Client , toxOnion :: Onion.Client RouteId , toxToRoute :: Transport String Onion.AnnouncedRendezvous (PublicKey,Onion.OnionData) , toxCrypto :: Transport String Multi.SessionAddress (CryptoPacket Encrypted) , toxHandshakes :: Transport String Multi.SessionAddress (Handshake Encrypted) , toxHandshakeCache :: HandshakeCache , toxCryptoKeys :: TransportCrypto , toxRouting :: DHT.Routing , toxTokens :: TVar SessionTokens , toxAnnouncedKeys :: TVar Onion.AnnouncedKeys , toxOnionRoutes :: OnionRouter , toxContactInfo :: ContactInfo extra , toxAnnounceToLan :: IO () , toxBindAddress :: SockAddr , toxRelayServer :: Maybe ServerHandle } -- | Create a DHTPublicKey packet to send to a remote contact. getContactInfo :: Maybe (RelayClient,PublicKey) -> Tox extra -> IO DHT.DHTPublicKey getContactInfo mthem Tox{toxCryptoKeys,toxRouting,toxOnionRoutes} = join $ atomically $ do (rcnt,relays) <- currentRelays (tcpRelayPinger toxOnionRoutes) r4 <- readTVar $ DHT.routing4 toxRouting r6 <- readTVar $ DHT.routing6 toxRouting nonce <- transportNewNonce toxCryptoKeys let self = nodeId n4 n4 = R.thisNode r4 n6 = R.thisNode r6 n4s = R.kclosest DHT.toxSpace 4 self r4 n6s = R.kclosest DHT.toxSpace 4 self r6 ns = filter (DHT.isGlobal . nodeIP) [n4,n6] ++ concat (zipWith (\a b -> [a,b]) n4s n6s) sending_ns = take 4 $ relays ++ map TCP.fromUDPNode ns return $ do forM_ mthem $ \(tcp,theirDHTKey) -> forM_ (filter (\n -> TCP.tcpPort n /= 0) sending_ns) $ \ni -> do Multi.tcpConnectionRequest tcp theirDHTKey ni timestamp <- round . (* 1000000) <$> getPOSIXTime return DHT.DHTPublicKey { dhtpkNonce = timestamp , dhtpk = id2key self , dhtpkNodes = DHT.SendNodes sending_ns } isLocalHost :: SockAddr -> Bool isLocalHost (SockAddrInet _ host32) = (fromBE32 host32 == 0x7f000001) isLocalHost _ = False addVerbosity :: Transport err SockAddr ByteString -> Transport err SockAddr ByteString addVerbosity tr = tr { awaitMessage = do (m,io) <- awaitMessage tr case m of Arrival addr msg -> return $ (,) m $ do io when (not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x82,0x8c,0x8d])) $ do mapM_ (\x -> dput XMisc ( (show addr) ++ " --> " ++ x)) $ xxd 0 msg _ -> return (m,io) , sendMessage = \addr msg -> do when (not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x8c,0x8d])) $ do mapM_ (\x -> dput XMisc ( (show addr) ++ " <-- " ++ x)) $ xxd 0 msg sendMessage tr addr msg } newKeysDatabase :: IO (TVar Onion.AnnouncedKeys) newKeysDatabase = atomically $ newTVar $ Onion.AnnouncedKeys PSQ.empty MinMaxPSQ.empty getOnionAlias :: TransportCrypto -> STM NodeInfo -> Maybe (Onion.OnionDestination r) -> IO (Onion.OnionDestination r) getOnionAlias crypto dhtself remoteNode = atomically $ do ni <- dhtself let alias = case remoteNode of Just (Onion.OnionDestination (Onion.AnnouncingAlias _ uk) _ _) -> ni { nodeId = key2id uk } _ -> ni { nodeId = key2id (onionAliasPublic crypto) } return $ Onion.OnionDestination Onion.SearchingAlias alias Nothing newTox :: TVar Onion.AnnouncedKeys -- ^ Store of announced keys we are a rendezvous for. -> [String] -- ^ Bind-address to listen on. Must provide at least one. -> ( ContactInfo extra -> SockAddr -> Session -> IO () ) -> (TransportCrypto, ContactInfo extra) -> Bool -- Enable TCP messages. -- ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses. XXX ignored -> IO (Tox extra) newTox keydb bindspecs onsess crypto usetcp = do msock <- Bind.udpTransport' True bindspecs let failedBind = do dput XMisc $ "tox udp bind error: " ++ show bindspecs throwIO $ userError "Tox UDP listen port?" fromMaybe failedBind $ msock <&> \(udp,sock) -> do addr <- getSocketName sock dput XMisc $ "UDP bind address: " ++ show addr (relay,sendTCP) <- if usetcp then do fmap (Just *** Just) $ tcpRelay (fst crypto) addr $ \a x -> do let bs = S.runPut $ Onion.putRequest x dput XOnion $ "Sending onion(0x" ++ (C8.unpack . Base16.encode) (B.take 1 bs) ++ ") from tcp-client to " ++ show a -- mapM_ (dput XOnion) (xxd2 0 bs) sendMessage udp (substituteLoopback addr a) bs else return (Nothing, Nothing) tox <- newToxOverTransport keydb addr onsess crypto udp sendTCP return tox { toxAnnounceToLan = announceToLan sock (key2id $ transportPublic $ toxCryptoKeys tox) , toxRelayServer = relay } newToxCrypto :: Maybe SecretKey -> IO (TransportCrypto, ContactInfo extra) newToxCrypto suppliedDHTKey = do roster <- newContactInfo crypto0 <- newCrypto let -- patch in supplied DHT key crypto1 = fromMaybe crypto0 $do k <- suppliedDHTKey return crypto0 { transportSecret = k , transportPublic = toPublic k } -- patch in newly allocated roster state. forM_ suppliedDHTKey $ \k -> do maybe (dput XMisc "failed to encode suppliedDHTKey") (dputB XMisc . C8.append "Using suppliedDHTKey: ") $ encodeSecret k return (crypto1 { userKeys = myKeyPairs roster }, roster ) -- | This version of 'newTox' is useful for automated tests using 'testPairTransport'. newToxOverTransport :: TVar Onion.AnnouncedKeys -> SockAddr -> ( ContactInfo extra -> SockAddr -> Session -> IO () ) -> (TransportCrypto, ContactInfo extra) -> Onion.UDPTransport -> Maybe ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses. -> IO (Tox extra) newToxOverTransport keydb addr onNewSession (crypto,roster) udp tcp = do drg <- drgNew let lookupClose _ = return Nothing mkrouting <- DHT.newRouting addr crypto updateIP updateIP (orouter,relaynet,onioncryptTCP) <- newOnionRouter crypto (dput XRoutes) (maybe False (const True) tcp) (cryptonet,dhtcrypt,onioncryptUDP,handshakes) <- toxTransport crypto orouter lookupClose addr udp relaynet (\dst x -> sendMessage (clientNet $ tcpClient $ tcpKademliaClient orouter) dst (True,x)) (fromMaybe (\_ _ -> return ()) tcp) sessions <- initSessions (sendMessage cryptonet) let dhtnet0 = layerTransportM (DHT.decrypt crypto Multi.nodeId) (DHT.encrypt crypto Multi.nodeId) dhtcrypt tbl4 = DHT.routing4 $ mkrouting (error "missing client") tbl6 = DHT.routing6 $ mkrouting (error "missing client") updateOnion bkts tr = hookBucketList DHT.toxSpace bkts orouter (trampolinesUDP orouter) tr updateOnUDP client = DHT.updateRouting client (mkrouting client) updateOnion -- -- I was going to update the kademlia tables on onion responses so -- -- that there is a pool of nodes to search without UDP, but it is a -- -- bad idea because the kademlia table update algorithm requires the -- -- ability to do a ping and it's not clear what that ping operation -- -- should be. -- updateOnTCP = const $ DHT.updateTable dhtclient (mkrouting client) updateOnion . udpNodeInfo dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr tbl4 tbl6) (DHT.handlers crypto . mkrouting) id (\client net -> onInbound (updateOnUDP client) net) hscache <- newHandshakeCache crypto $ \saddr hs -> do saddr' <- case saddr of Multi.SessionTCP :=> Identity (ViaRelay Nothing nid relay) -> do let relayclient = relayClient $ tcpRelayPinger orouter msaddr <- Multi.tcpConnectionRequest relayclient (id2key nid) relay when (isNothing msaddr) $ dput XMan $ "Unable to establish relay connection!" return $ maybe saddr Multi.sessionAddr msaddr _ -> return saddr sendMessage handshakes saddr' hs return saddr' let sparams = SessionParams { spCrypto = crypto , spSessions = sessions , spGetSentHandshake = getSentHandshake hscache , spOnNewSession = onNewSession roster addr } -- TODO: Refactor so that these threads are forked when 'forkTox' is invoked. -- This function should only initialize state. orouter' <- forkRouteBuilder orouter $ \nid ni -> fmap (\(_,ns,_)->ns) . resultToMaybe <$> DHT.getNodes dhtclient (DHT.nodesOfInterest $ mkrouting dhtclient) nid (Multi.UDP ==> ni) toks <- do nil <- nullSessionTokens atomically $ newTVar nil { maxInterval = 20 } -- 20 second timeout on announce ping-ids. onioncrypt <- layerTransportM (\msg addr -> return $ Right (msg,Multi.untagOnion addr)) (\msg addr -> do -- TODO: lookupRoute is unnecessarily done twice -- because that was convenient for me. The other -- call was done when building the onioncryptUDP -- transport. -- Consider simplifying this. mtcp <- case addr of Onion.OnionDestination _ ni (Just rid) -> (>>= Onion.routeRelayPort) <$> lookupRoute orouter' ni rid _ -> return Nothing return (msg, maybe (Multi.OnionUDP ==> addr) (const $ Multi.OnionTCP ==> addr) mtcp)) <$> mergeTransports (DMap.fromList [ Multi.OnionUDP :=> ByAddress onioncryptUDP , Multi.OnionTCP :=> ByAddress {- onInbound updateOnTCP -} onioncryptTCP ]) -- dtacrypt :: Transport String AnnouncedRendezvous (PublicKey,OnionData) (dtacrypt,onioncrypt) <- partitionTransportM (Onion.parseDataToRoute crypto) (Onion.encodeDataToRoute crypto) onioncrypt oniondrg <- drgNew let onionnet = layerTransportM (\msg od -> Onion.decrypt crypto msg od) (\msg od -> Onion.encrypt crypto msg od) onioncrypt onionclient <- newClient oniondrg onionnet (const Onion.classify) (getOnionAlias crypto $ R.thisNode <$> readTVar (DHT.routing4 $ mkrouting dhtclient)) (const $ Onion.handlers onionnet (mkrouting dhtclient) toks keydb) (hookQueries orouter' DHT.transactionKey) (const id) return Tox { toxDHT = dhtclient , toxOnion = onionclient , toxToRoute = onInbound (updateContactInfo roster) dtacrypt , toxCrypto = addHandler (sessionHandler sessions) cryptonet , toxHandshakes = addHandler (handshakeH sparams) handshakes , toxHandshakeCache = hscache , toxCryptoKeys = crypto , toxRouting = mkrouting dhtclient , toxTokens = toks , toxAnnouncedKeys = keydb , toxOnionRoutes = orouter' -- TODO: see above , toxContactInfo = roster , toxAnnounceToLan = return () , toxBindAddress = addr , toxRelayServer = Nothing } onionTimeout :: Tox extra -> Onion.OnionDestination RouteId -> STM (Onion.OnionDestination RouteId, Int) onionTimeout Tox { toxOnionRoutes = or } od = lookupTimeout or od routing4nodeInfo :: DHT.Routing -> IO NodeInfo routing4nodeInfo (DHT.routing4 -> tv) = R.thisNode <$> readTVarIO tv dnssdAnnounce :: Tox extra -> IO () dnssdAnnounce tox = do ni <- routing4nodeInfo (toxRouting tox) keys <- fmap (key2id . snd) <$> atomically (userKeys $ toxCryptoKeys tox) announceToxService (nodePort ni) (nodeId ni) (listToMaybe keys) dnssdDiscover :: Tox extra -> NodeInfo -> (Maybe NodeId) -> IO () dnssdDiscover tox ni toxid = do acts <- atomically $ readTVar $ accounts $ toxContactInfo tox now <- getPOSIXTime forM toxid $ \tid -> forM acts $ \act -> atomically $ setContactAddr now (id2key tid) ni act void $ DHT.pingUDP (toxDHT tox) ni -- | Log a dbus error putDBusError :: Bool -> String -> IO () putDBusError bFatal msg = do let fatality = if bFatal then "Fatal" else "Non-Fatal" prefix = fatality <> " DBus Exception: " dput XDBus (prefix <> msg) -- | Returns: -- -- * action to shutdown this node, terminating all threads. -- -- * action to bootstrap an IPv4 Kademlia table. -- -- * action to bootstrap an IPv6 Kademlia table. forkTox :: Tox extra -> Bool -- avahi -> Bool -- tcp -> IO (IO (), [NodeInfo] -> [NodeInfo] -> IO (), [NodeInfo] -> [NodeInfo] -> IO ()) forkTox tox with_avahi with_tcp = do quitHs <- forkListener "toxHandshakes" (dput XMan . mappend "hs-parse: ") (toxHandshakes tox) quitToRoute <- forkListener "toxToRoute" (dput XOnion . mappend "dta-parse: ") (toxToRoute tox) quitOnion <- forkListener "toxOnion" (dput XOnion . mappend "onion-parse: ") (clientNet $ toxOnion tox) quitDHT <- forkListener "toxDHT" (dput XDHT . mappend "dht-parse: ") (clientNet $ toxDHT tox) quitNC <- forkListener "toxCrypto" (dput XNetCrypto . mappend "nc-parse: ") (toxCrypto tox) quitTCP <- if with_tcp then forkListener "relay-client" (dput XTCP . mappend "tcp-parse: ") (clientNet $ tcpClient $ tcpKademliaClient $ toxOnionRoutes tox) else return $ return () refresher4 <- forkPollForRefresh (DHT.refresher4 $ toxRouting tox) refresher6 <- forkPollForRefresh (DHT.refresher6 $ toxRouting tox) quitAvahi <- if with_avahi then do dnssdIn <- forkIO (queryToxService (dnssdDiscover tox) `catch` \(e::DBus.ClientError) -> putDBusError (DBus.clientErrorFatal e) (DBus.clientErrorMessage e)) dnssdOut <- forkIO ( dnssdAnnounce tox `catch` \(e::DBus.ClientError) -> putDBusError (DBus.clientErrorFatal e) (DBus.clientErrorMessage e)) labelThread dnssdIn "tox-avahi-monitor" labelThread dnssdOut "tox-avahi-publish" return $ forM_ [dnssdIn,dnssdOut] killThread else return $ return () keygc <- Onion.forkAnnouncedKeysGC (toxAnnouncedKeys tox) return ( do killThread refresher4 killThread refresher6 quitAvahi killThread keygc quitNC quitDHT quitOnion quitTCP quitRouteBuilder (toxOnionRoutes tox) quitToRoute quitHs mapM_ quitListening (toxRelayServer tox) , bootstrap (DHT.refresher4 $ toxRouting tox) , bootstrap (DHT.refresher6 $ toxRouting tox) ) -- TODO: Don't export this. The exported interface is 'toxAnnounceToLan'. announceToLan :: Socket -> NodeId -> IO () announceToLan sock nid = do addrs <- broadcastAddrs forM_ addrs $ \addr -> do (broadcast_info:_) <- getAddrInfo (Just defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram }) (Just addr) (Just "33445") let broadcast = addrAddress broadcast_info bs = S.runPut $ DHT.putMessage (DHT.DHTLanDiscovery nid) dput XLan $ show broadcast ++ " <-- LanAnnounce " ++ show nid saferSendTo sock bs broadcast toxQSearch :: Tox extra -> Search NodeId (IP, PortNumber) Nonce32 NodeInfo Onion.Rendezvous DHT.TransactionId toxQSearch tox = Onion.toxidSearch (onionTimeout tox) (toxCryptoKeys tox) (toxOnion tox)