{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} module Network.Tox where import Debug.Trace import Control.Exception hiding (Handler) import Control.Applicative import Control.Arrow import Control.Concurrent (MVar) import Control.Concurrent.STM import Control.Monad import Control.Monad.Fix import qualified Crypto.Cipher.ChaChaPoly1305 as Symmetric import qualified Crypto.Cipher.Salsa as Salsa import qualified Crypto.Cipher.XSalsa as XSalsa import Crypto.ECC.Class import qualified Crypto.Error as Cryptonite import Crypto.Error.Types import qualified Crypto.MAC.Poly1305 as Poly1305 import Crypto.PubKey.Curve25519 import Crypto.PubKey.ECC.Types import Crypto.Random import qualified Data.Aeson as JSON ;import Data.Aeson (FromJSON, ToJSON, (.=)) import Data.Bitraversable (bisequence) import Data.Bits import Data.Bits.ByteString () import Data.Bool import qualified Data.ByteArray as BA ;import Data.ByteArray (ByteArrayAccess, Bytes) import qualified Data.ByteString as B ;import Data.ByteString (ByteString) import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Char8 as C8 import Data.ByteString.Lazy (toStrict) import Data.Char import Data.Data import Data.Functor.Contravariant import Data.Hashable import Data.IP import Data.Maybe import qualified Data.MinMaxPSQ as MinMaxPSQ ;import Data.MinMaxPSQ (MinMaxPSQ') import Data.Monoid import Data.Ord import qualified Data.Serialize as S import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) import Data.Typeable import Data.Word import qualified Data.Wrapper.PSQ as PSQ ;import Data.Wrapper.PSQ (PSQ) import qualified Data.Wrapper.PSQInt as Int import Foreign.Marshal.Alloc import Foreign.Ptr import Foreign.Storable import GHC.Generics (Generic) import System.Global6 import Network.Kademlia import Network.Address (Address, WantIP (..), either4or6, fromSockAddr, ipFamily, setPort, sockAddrPort, testIdBit, toSockAddr, un4map) import Network.Kademlia.Search (Search (..)) import qualified Network.Kademlia.Routing as R import Network.QueryResponse import Network.Socket import System.Endian import System.IO import qualified Text.ParserCombinators.ReadP as RP import Text.Printf import Text.Read import Control.TriadCommittee import Network.BitTorrent.DHT.Token as Token import GHC.TypeLits import Crypto.Tox import Data.Word64Map (fitsInInt) import qualified Data.Word64Map (empty) import Network.Tox.Crypto.Transport (NetCrypto) 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.Transport import OnionRouter import Roster import Text.XXD newCrypto :: IO TransportCrypto newCrypto = do secret <- generateSecretKey alias <- generateSecretKey ralias <- generateSecretKey let pubkey = toPublic secret aliaspub = toPublic alias raliaspub = toPublic ralias ukeys <- atomically $ newTVar [] (symkey, drg) <- do drg0 <- getSystemDRG return $ randomBytesGenerate 32 drg0 :: IO (ByteString, SystemDRG) noncevar <- atomically $ newTVar $ fst $ withDRG drg drgNew cookieKeys <- atomically $ newTVar [] hPutStrLn stderr $ "secret(tox) = " ++ DHT.showHex secret hPutStrLn stderr $ "public(tox) = " ++ DHT.showHex pubkey hPutStrLn stderr $ "symmetric(tox) = " ++ DHT.showHex symkey return TransportCrypto { transportSecret = secret , transportPublic = pubkey , onionAliasSecret = alias , onionAliasPublic = aliaspub , rendezvousSecret = ralias , rendezvousPublic = raliaspub , transportSymmetric = return $ SymmetricKey symkey , transportNewNonce = do drg1 <- readTVar noncevar let (nonce, drg2) = withDRG drg1 (Nonce24 <$> getRandomBytes 24) writeTVar noncevar drg2 return nonce , userKeys = ukeys , pendingCookies = cookieKeys } 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 myAddr :: DHT.Routing -> Maybe NodeInfo -> IO NodeInfo myAddr routing maddr = atomically $ do let var = case flip DHT.prefer4or6 Nothing <$> maddr of Just Want_IP6 -> DHT.routing6 routing _ -> DHT.routing4 routing a <- readTVar var return $ R.thisNode a newClient :: (DRG g, Show addr, Show meth) => g -> Transport String addr x -> (x -> MessageClass String meth DHT.TransactionId) -> (Maybe addr -> IO addr) -> (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 tbl var handlers = DispatchMethods { classifyInbound = classify , lookupHandler = handlers -- var , tableMethods = modifytbl tbl } eprinter = printErrors stderr mkclient (tbl,var) handlers = let client = Client { clientNet = addHandler eprinter (handleMessage client) $ modifynet client net , clientDispatcher = dispatch tbl var handlers , clientErrorReporter = eprinter { reportTimeout = reportTimeout ignoreErrors } , clientPending = var , clientAddress = selfAddr , clientResponseId = genNonce24 var } in client return $ either mkclient mkclient tblvar handlers data Tox = Tox { toxDHT :: DHT.Client , toxOnion :: Onion.Client RouteId , toxToRoute :: Transport String Onion.AnnouncedRendezvous (PublicKey,Onion.OnionData) , toxCrypto :: Transport String SockAddr NetCrypto , toxCryptoKeys :: TransportCrypto , toxRouting :: DHT.Routing , toxTokens :: TVar SessionTokens , toxAnnouncedKeys :: TVar Onion.AnnouncedKeys , toxOnionRoutes :: OnionRouter , toxRoster :: Roster } getContactInfo :: Tox -> IO DHT.DHTPublicKey getContactInfo Tox{toxCryptoKeys,toxRouting} = join $ atomically $ do 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) return $ do timestamp <- round . (* 1000000) <$> getPOSIXTime return DHT.DHTPublicKey { dhtpkNonce = timestamp , dhtpk = id2key self , dhtpkNodes = DHT.SendNodes $ take 4 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 = \kont -> awaitMessage tr $ \m -> do forM_ m $ mapM_ $ \(msg,addr) -> do when (not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x82,0x8c,0x8d])) $ do mapM_ (\x -> hPutStrLn stderr ( (show addr) ++ " --> " ++ x)) $ xxd 0 msg kont m , sendMessage = \addr msg -> do when (not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x8c,0x8d])) $ do mapM_ (\x -> hPutStrLn stderr ( (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 -> SockAddr -> IO Tox newTox keydb addr = do udp <- addVerbosity <$> udpTransport addr crypto <- newCrypto drg <- drgNew let lookupClose _ = return Nothing routing <- DHT.newRouting addr crypto updateIP updateIP orouter <- newOnionRouter (dhtcrypt,onioncrypt,dtacrypt,cryptonet) <- toxTransport crypto orouter lookupClose udp let dhtnet0 = layerTransport (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr routing) (DHT.handlers crypto routing) id $ \client net -> onInbound (DHT.updateRouting client routing orouter) net orouter <- forkRouteBuilder orouter $ \nid ni -> maybe [] (\(_,ns,_)->ns) <$> DHT.getNodes dhtclient nid ni toks <- do nil <- nullSessionTokens atomically $ newTVar nil { maxInterval = 20 } -- 20 second timeout on announce ping-ids. oniondrg <- drgNew let onionnet = layerTransportM (Onion.decrypt crypto) (Onion.encrypt crypto) onioncrypt onionclient <- newClient oniondrg onionnet Onion.classify (getOnionAlias crypto $ R.thisNode <$> readTVar (DHT.routing4 routing)) (Onion.handlers onionnet routing toks keydb) (hookQueries orouter DHT.transactionKey) (const id) roster <- newRoster return Tox { toxDHT = dhtclient , toxOnion = onionclient , toxToRoute = onInbound (updateRoster roster) dtacrypt , toxCrypto = cryptonet , toxCryptoKeys = crypto , toxRouting = routing , toxTokens = toks , toxAnnouncedKeys = keydb , toxOnionRoutes = orouter , toxRoster = roster } onionTimeout :: Tox -> DHT.TransactionId -> Onion.OnionDestination RouteId -> STM (Onion.OnionDestination RouteId, Int) onionTimeout Tox { toxOnionRoutes = or } (DHT.TransactionId n8 _) od = lookupTimeout or n8 od forkTox :: Tox -> IO (IO ()) forkTox tox = do _ <- forkListener "toxCrypto" (toxCrypto tox) _ <- forkListener "toxToRoute" (toxToRoute tox) _ <- forkListener "toxOnion" (clientNet $ toxOnion tox) forkListener "toxDHT" (clientNet $ toxDHT tox)