From d830e5d9a18646e8f9fecf4ce74ac0250a3e9021 Mon Sep 17 00:00:00 2001 From: joe Date: Fri, 15 Sep 2017 04:34:27 -0400 Subject: Moved top-level Tox module to hierarchical location. --- Tox.hs | 255 ----------------------------------------------------- examples/dhtd.hs | 2 +- src/Network/Tox.hs | 255 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 256 insertions(+), 256 deletions(-) delete mode 100644 Tox.hs create mode 100644 src/Network/Tox.hs diff --git a/Tox.hs b/Tox.hs deleted file mode 100644 index 98c3811b..00000000 --- a/Tox.hs +++ /dev/null @@ -1,255 +0,0 @@ -{-# 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 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 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.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.BitTorrent.DHT.Search (Search (..)) -import qualified Network.DHT.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 hiding (Assym) -import Network.Tox.Transport -import Network.Tox.Address -import qualified Network.Tox.DHT.Transport as DHT -import qualified Network.Tox.DHT.Handlers as DHT -import qualified Network.Tox.Onion.Transport as Onion -import qualified Network.Tox.Onion.Handlers as Onion -import Network.Tox.Crypto.Transport (NetCrypto) -import Text.XXD - -newCrypto :: IO TransportCrypto -newCrypto = do - secret <- generateSecretKey - let pubkey = toPublic secret - (symkey, drg) <- do - drg0 <- getSystemDRG - return $ randomBytesGenerate 32 drg0 :: IO (ByteString, SystemDRG) - noncevar <- atomically $ newTVar $ fst $ withDRG drg drgNew - 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 - , transportSymmetric = return $ SymmetricKey symkey - , transportNewNonce = do - drg1 <- readTVar noncevar - let (nonce, drg2) = withDRG drg1 (Nonce24 <$> getRandomBytes 24) - writeTVar noncevar drg2 - return nonce - } - -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 - -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)) - -> (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 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 (contramapT intKey intMapMethods) gen - intmap_var <- atomically $ newTVar (drg, mempty) - return $ Right (intmapT,intmap_var) - else do - let mapT = transactionMethods (contramapT nonceKey mapMethods) gen - map_var <- atomically $ newTVar (drg, mempty) - return $ Left (mapT,map_var) - let dispatch tbl var handlers = DispatchMethods - { classifyInbound = classify - , lookupHandler = handlers -- var - , tableMethods = tbl - } - mkclient (tbl,var) handlers = - let client = Client - { clientNet = addHandler (handleMessage client) $ modifynet client net - , clientDispatcher = dispatch tbl var handlers -- (fmap (contramapAddr (\(ToxPath ni _) -> ni)) . handlers) - , clientErrorReporter = (printErrors stderr) { 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 - , toxCrypto :: Transport String SockAddr NetCrypto - , toxRouting :: DHT.Routing - , toxTokens :: TVar SessionTokens - , toxAnnouncedKeys :: TVar Onion.AnnouncedKeys - } - -addVerbosity :: Show addr => Transport err addr ByteString -> Transport err addr 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])) $ 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])) $ 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 - -newTox :: TVar Onion.AnnouncedKeys -> SockAddr -> IO Tox -newTox keydb addr = do - udp <- addVerbosity <$> udpTransport addr - crypto <- newCrypto - drg <- drgNew - let lookupClose _ = return Nothing - (dhtcrypt,onioncrypt,cryptonet) <- toxTransport crypto lookupClose udp - - routing <- DHT.newRouting addr crypto updateIP updateIP - let dhtnet0 = layerTransport (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt - dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr routing) (DHT.handlers routing) - $ \client net -> onInbound (DHT.updateRouting client routing) net - - toks <- do - nil <- nullSessionTokens - atomically $ newTVar nil { maxInterval = 20 } -- 20 second timeout on announce ping-ids. - oniondrg <- drgNew - let onionnet = layerTransport (Onion.decrypt crypto) (Onion.encrypt crypto) onioncrypt - onionclient <- newClient oniondrg onionnet Onion.classify (const $ return $ Onion.OnionToMe addr) - (Onion.handlers onionnet routing toks keydb) - (const id) - return Tox - { toxDHT = dhtclient - , toxOnion = onionclient - , toxCrypto = cryptonet - , toxRouting = routing - , toxTokens = toks - , toxAnnouncedKeys = keydb - } - -forkTox :: Tox -> IO (IO ()) -forkTox tox = do - _ <- forkListener "toxCrypto" (toxCrypto tox) - _ <- forkListener "toxOnion" (clientNet $ toxOnion tox) - forkListener "toxDHT" (clientNet $ toxDHT tox) - diff --git a/examples/dhtd.hs b/examples/dhtd.hs index 167b9b44..198ab203 100644 --- a/examples/dhtd.hs +++ b/examples/dhtd.hs @@ -51,7 +51,7 @@ import Network.QueryResponse import Network.StreamServer import Network.Kademlia import qualified Network.BitTorrent.MainlineDHT as Mainline -import qualified Tox +import qualified Network.Tox as Tox import Network.DHT.Routing as R import Data.Aeson as J (ToJSON, FromJSON) import qualified Data.Aeson as J diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs new file mode 100644 index 00000000..c88dbcd4 --- /dev/null +++ b/src/Network/Tox.hs @@ -0,0 +1,255 @@ +{-# 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 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.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.BitTorrent.DHT.Search (Search (..)) +import qualified Network.DHT.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 hiding (Assym) +import Network.Tox.Transport +import Network.Tox.Address +import qualified Network.Tox.DHT.Transport as DHT +import qualified Network.Tox.DHT.Handlers as DHT +import qualified Network.Tox.Onion.Transport as Onion +import qualified Network.Tox.Onion.Handlers as Onion +import Network.Tox.Crypto.Transport (NetCrypto) +import Text.XXD + +newCrypto :: IO TransportCrypto +newCrypto = do + secret <- generateSecretKey + let pubkey = toPublic secret + (symkey, drg) <- do + drg0 <- getSystemDRG + return $ randomBytesGenerate 32 drg0 :: IO (ByteString, SystemDRG) + noncevar <- atomically $ newTVar $ fst $ withDRG drg drgNew + 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 + , transportSymmetric = return $ SymmetricKey symkey + , transportNewNonce = do + drg1 <- readTVar noncevar + let (nonce, drg2) = withDRG drg1 (Nonce24 <$> getRandomBytes 24) + writeTVar noncevar drg2 + return nonce + } + +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 + +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)) + -> (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 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 (contramapT intKey intMapMethods) gen + intmap_var <- atomically $ newTVar (drg, mempty) + return $ Right (intmapT,intmap_var) + else do + let mapT = transactionMethods (contramapT nonceKey mapMethods) gen + map_var <- atomically $ newTVar (drg, mempty) + return $ Left (mapT,map_var) + let dispatch tbl var handlers = DispatchMethods + { classifyInbound = classify + , lookupHandler = handlers -- var + , tableMethods = tbl + } + mkclient (tbl,var) handlers = + let client = Client + { clientNet = addHandler (handleMessage client) $ modifynet client net + , clientDispatcher = dispatch tbl var handlers -- (fmap (contramapAddr (\(ToxPath ni _) -> ni)) . handlers) + , clientErrorReporter = (printErrors stderr) { 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 + , toxCrypto :: Transport String SockAddr NetCrypto + , toxRouting :: DHT.Routing + , toxTokens :: TVar SessionTokens + , toxAnnouncedKeys :: TVar Onion.AnnouncedKeys + } + +addVerbosity :: Show addr => Transport err addr ByteString -> Transport err addr 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])) $ 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])) $ 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 + +newTox :: TVar Onion.AnnouncedKeys -> SockAddr -> IO Tox +newTox keydb addr = do + udp <- addVerbosity <$> udpTransport addr + crypto <- newCrypto + drg <- drgNew + let lookupClose _ = return Nothing + (dhtcrypt,onioncrypt,cryptonet) <- toxTransport crypto lookupClose udp + + routing <- DHT.newRouting addr crypto updateIP updateIP + let dhtnet0 = layerTransport (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt + dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr routing) (DHT.handlers routing) + $ \client net -> onInbound (DHT.updateRouting client routing) net + + toks <- do + nil <- nullSessionTokens + atomically $ newTVar nil { maxInterval = 20 } -- 20 second timeout on announce ping-ids. + oniondrg <- drgNew + let onionnet = layerTransport (Onion.decrypt crypto) (Onion.encrypt crypto) onioncrypt + onionclient <- newClient oniondrg onionnet Onion.classify (const $ return $ Onion.OnionToMe addr) + (Onion.handlers onionnet routing toks keydb) + (const id) + return Tox + { toxDHT = dhtclient + , toxOnion = onionclient + , toxCrypto = cryptonet + , toxRouting = routing + , toxTokens = toks + , toxAnnouncedKeys = keydb + } + +forkTox :: Tox -> IO (IO ()) +forkTox tox = do + _ <- forkListener "toxCrypto" (toxCrypto tox) + _ <- forkListener "toxOnion" (clientNet $ toxOnion tox) + forkListener "toxDHT" (clientNet $ toxDHT tox) + -- cgit v1.2.3