From 37a7fa4978f89072d9231bcc9bd0848bb52c676c Mon Sep 17 00:00:00 2001 From: joe Date: Thu, 12 Oct 2017 05:41:09 -0400 Subject: WIP Onion routing. --- src/Network/Tox/Onion/Handlers.hs | 81 ++++++++++++++++++++++++++++++++++----- 1 file changed, 72 insertions(+), 9 deletions(-) (limited to 'src/Network/Tox/Onion/Handlers.hs') diff --git a/src/Network/Tox/Onion/Handlers.hs b/src/Network/Tox/Onion/Handlers.hs index 08f5cabd..91dd843e 100644 --- a/src/Network/Tox/Onion/Handlers.hs +++ b/src/Network/Tox/Onion/Handlers.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} module Network.Tox.Onion.Handlers where +import Network.Kademlia.Search import Network.Tox.DHT.Transport import Network.Tox.DHT.Handlers hiding (Message,Client) import Network.Tox.Onion.Transport @@ -11,9 +13,11 @@ import qualified Data.Wrapper.PSQ as PSQ ;import Data.Wrapper.PSQ (PSQ) import Crypto.Error.Types (CryptoFailable (..), throwCryptoError) +import Control.Arrow import System.IO import qualified Data.ByteArray as BA +import Data.Function import Data.Serialize as S import qualified Data.Wrapper.PSQInt as Int import Network.Kademlia @@ -59,23 +63,27 @@ classify msg = go msg -- The reason for this 20 second timeout in toxcore is that it gives a reasonable -- time (20 to 40 seconds) for a peer to announce himself while taking in count -- all the possible delays with some extra seconds. +-- dhtd: src/Network/Tox/Onion/Handlers.hs:(67,1)-(101,23): Non-exhaustive patterns in function announceH announceH :: Routing -> TVar SessionTokens -> TVar AnnouncedKeys -> OnionDestination r -> AnnounceRequest -> IO AnnounceResponse -announceH routing toks keydb (OnionToOwner naddr retpath) req = do +announceH routing toks keydb oaddr req = do case () of _ | announcePingId req == zeros32 -> go False _ -> let Nonce32 bs = announcePingId req tok = fromPaddedByteString 32 bs - in checkToken toks naddr tok >>= go + in checkToken toks (onionNodeInfo oaddr) tok >>= go `catch` (\(SomeException e) -> hPutStrLn stderr ("announceH Exception! "++show e) >> throw e) where go withTok = do + let naddr = onionNodeInfo oaddr ns <- getNodesH routing naddr (GetNodes (announceSeeking req)) tm <- getPOSIXTime - let storing = (nodeId naddr == announceSeeking req) + let storing = case oaddr of + OnionToOwner _ pth -> guard (nodeId naddr == announceSeeking req) >> Just pth + _ -> Nothing record <- atomically $ do - when (withTok && storing) $ do + forM_ storing $ \retpath -> when withTok $ do let toxpath = AnnouncedRoute naddr{ nodeId = announceKey req } retpath -- Note: The following distance calculation assumes that -- our nodeid doesn't change and is the same for both @@ -85,12 +93,12 @@ announceH routing toks keydb (OnionToOwner naddr retpath) req = do modifyTVar' keydb (insertKey tm (announceSeeking req) toxpath d) ks <- readTVar keydb return $ snd . snd <$> MinMaxPSQ.lookup' (announceSeeking req) (keyAssoc ks) - newtok <- if storing - then Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr - else return $ zeros32 + newtok <- maybe (return $ zeros32) + (const $ Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr) + storing let k = case record of Nothing -> NotStored newtok - Just _ | storing -> Acknowledged newtok + Just _ | isJust storing -> Acknowledged newtok Just (AnnouncedRoute ni _) -> SendBackKey $ id2key (nodeId ni) let response = AnnounceResponse k ns hPutStrLn stderr $ unwords ["Announce:", show req, "-reply->", show response] @@ -151,3 +159,58 @@ handlers net routing toks keydb AnnounceType $ announceH routing toks keydb handlers net _ _ keydb _ = Just $ NoReply Right $ dataToRouteH keydb net +toxidSearch :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) + -> Client r + -> Search NodeId (IP, PortNumber) (Maybe Nonce32) NodeInfo PublicKey +toxidSearch getTimeout client = Search + { searchSpace = toxSpace + , searchNodeAddress = nodeIP &&& nodePort + , searchQuery = announce getTimeout client + } + +announceSerializer :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) + -> MethodSerializer + TransactionId + (OnionDestination r) + (OnionMessage Identity) + PacketKind + AnnounceRequest + (Maybe AnnounceResponse) +announceSerializer getTimeout = MethodSerializer + { methodTimeout = getTimeout + , method = AnnounceType + , wrapQuery = \(TransactionId n8 n24) src dst req -> + -- :: tid -> addr -> addr -> a -> OnionMessage Identity + OnionAnnounce $ Assym + { -- The public key is our real long term public key if we want to + -- announce ourselves, a temporary one if we are searching for + -- friends. + senderKey = fromJust $ onionKey src -- TODO: FIXME: this should be a temporary alias key + , assymNonce = n24 + , assymData = Identity (req, n8) + } + , unwrapResponse = \case -- :: OnionMessage Identity -> b + OnionAnnounceResponse _ _ resp -> Just $ runIdentity resp + _ -> Nothing + } + +unwrapAnnounceResponse :: AnnounceResponse -> ([NodeInfo], [PublicKey], Maybe Nonce32) +unwrapAnnounceResponse (AnnounceResponse is_stored (SendNodes ns)) + = case is_stored of + NotStored n32 -> (ns, [], Just n32) + SendBackKey k -> (ns, [k], Nothing) + Acknowledged n32 -> (ns, [], Just n32) + +announce :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) + -> Client r + -> NodeId + -> NodeInfo + -> IO (Maybe ([NodeInfo],[PublicKey],Maybe Nonce32)) +announce getTimeout client nid ni = + -- Four tries and then we tap out. + flip fix 4 $ \loop n -> do + let oaddr = OnionDestination ni Nothing + mb <- QR.sendQuery client (announceSerializer getTimeout) (AnnounceRequest zeros32 nid zeroID) oaddr + maybe (if n>0 then loop $! n - 1 else return Nothing) + (return . Just . unwrapAnnounceResponse) + $ join mb -- cgit v1.2.3