From c781c88c3cd77b70694a26c3f27ff82aa6fa65d3 Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Sun, 24 Jun 2018 05:02:34 -0400 Subject: Fixed handshake behavior The handshake code would flood the network with interminable handshakes. --- Announcer.hs | 8 +-- Connection/Tox.hs | 8 +-- Connection/Tox/Threads.hs | 6 +- ToxManager.hs | 4 +- ToxToXMPP.hs | 128 ++++++++++++++++++++++++----------------- examples/dhtd.hs | 8 +-- src/Network/Tox.hs | 6 +- src/Network/Tox/ContactInfo.hs | 19 ++++-- 8 files changed, 108 insertions(+), 79 deletions(-) diff --git a/Announcer.hs b/Announcer.hs index 41c1c2a6..89dc5c3b 100644 --- a/Announcer.hs +++ b/Announcer.hs @@ -46,11 +46,11 @@ newtype AnnounceKey = AnnounceKey ByteString instance Show AnnounceKey where show (AnnounceKey bs) = "AnnounceKey " ++ show (Char8.unpack bs) -packAnnounceKey :: Announcer -> String -> STM AnnounceKey -packAnnounceKey _ = return . AnnounceKey . Char8.pack +packAnnounceKey :: Announcer -> String -> AnnounceKey +packAnnounceKey _ = AnnounceKey . Char8.pack -unpackAnnounceKey :: Announcer -> AnnounceKey -> STM String -unpackAnnounceKey _ (AnnounceKey bs) = return $ Char8.unpack bs +unpackAnnounceKey :: Announcer -> AnnounceKey -> String +unpackAnnounceKey _ (AnnounceKey bs) = Char8.unpack bs -- | Actions that can be scheduled to occur at some particular time in the -- future. Since periodic event handlers are responsible for re-scheduling diff --git a/Connection/Tox.hs b/Connection/Tox.hs index 3f5f7e2c..9612f1e5 100644 --- a/Connection/Tox.hs +++ b/Connection/Tox.hs @@ -193,12 +193,12 @@ setToxPolicy params conmap k@(Key me them) policy = do registerNodeCallback routing $ NodeInfoCallback { interestingNodeId = nid , listenerId = callbackId - , observedAddress = \now ni -> writeTVar (contactLastSeenAddr c) (Just (now,nodeAddr ni)) + , observedAddress = \now ni -> writeTVar (contactLastSeenAddr c) (Just (now, ni)) , rumoredAddress = \now saddr ni -> do m <- readTVar (contactLastSeenAddr c) -- TODO remember information source and handle multiple rumors. case m of Just _ -> return () - Nothing -> writeTVar (contactLastSeenAddr c) (Just (now,nodeAddr ni)) + Nothing -> writeTVar (contactLastSeenAddr c) (Just (now, ni)) } return () RefusingToConnect -> do -- disconnect or cancel any pending connection @@ -235,12 +235,12 @@ setToxPolicy params conmap k@(Key me them) policy = do registerNodeCallback routing $ NodeInfoCallback { interestingNodeId = nid , listenerId = callbackId - , observedAddress = \now ni -> writeTVar (contactLastSeenAddr c) (Just (now,nodeAddr ni)) + , observedAddress = \now ni -> writeTVar (contactLastSeenAddr c) (Just (now, ni)) , rumoredAddress = \now saddr ni -> do m <- readTVar (contactLastSeenAddr c) -- TODO remember information source and handle multiple rumors. case m of Just _ -> return () - Nothing -> writeTVar (contactLastSeenAddr c) (Just (now,nodeAddr ni)) + Nothing -> writeTVar (contactLastSeenAddr c) (Just (now, ni)) } stringToKey_ :: String -> Maybe Key diff --git a/Connection/Tox/Threads.hs b/Connection/Tox/Threads.hs index ba49b7dc..de719655 100644 --- a/Connection/Tox/Threads.hs +++ b/Connection/Tox/Threads.hs @@ -140,7 +140,7 @@ pursueContact getPolicy getStatus PursueContactMethods{..} statusVar = do (do (stamp_theirDhtKey,theirDhtKey) <- second DHT.dhtpk <$> retryUntilJust (contactKeyPacket contact) (stamp_saddr,saddr) <- retryUntilJust (contactLastSeenAddr contact) - ni <- either (const retry) return $ nodeInfo (key2id theirDhtKey) saddr + ni <- either (const retry) return $ nodeInfo (key2id theirDhtKey) (_fixme saddr) return $ do -- AcquiringCookie atomically $ writeTVar statusVar (InProgress AcquiringCookie) @@ -166,11 +166,11 @@ pursueContact getPolicy getStatus PursueContactMethods{..} statusVar = do newsession <- generateSecretKey timestamp <- getPOSIXTime (myhandshake,ioAction) - <- atomically $ freshCryptoSession allsessions saddr newsession timestamp hp + <- atomically $ freshCryptoSession allsessions (_fixme saddr) newsession timestamp hp ioAction -- send handshake forM myhandshake $ \response_handshake -> do - sendHandshake allsessions saddr response_handshake + sendHandshake allsessions (_fixme saddr) response_handshake atomically $ writeTVar statusVar $ InProgress AwaitingHandshake return shortRetryInterval -- AwaitingHandshake diff --git a/ToxManager.hs b/ToxManager.hs index bcc4d86d..360f78e8 100644 --- a/ToxManager.hs +++ b/ToxManager.hs @@ -78,7 +78,7 @@ toxman announcer toxbkts tox presence = ToxManager forM_ newlyActive $ \nearNodes -> do -- Schedule recurring announce. -- - akey <- atomically $ packAnnounceKey announcer $ "toxid:" ++ show pubid + let akey = packAnnounceKey announcer $ "toxid:" ++ show pubid scheduleAnnounce announcer akey (AnnounceMethod (toxQSearch tox) @@ -109,7 +109,7 @@ toxman announcer toxbkts tox presence = ToxManager -- Stop the recurring search for that contact -- -- Stop recurring announce. - akey <- packAnnounceKey announcer ("toxid:" ++ show pubid) + let akey = packAnnounceKey announcer ("toxid:" ++ show pubid) fmap Just $ forM toxbkts $ \(nm,bkts) -> do return (akey,bkts) else return Nothing diff --git a/ToxToXMPP.hs b/ToxToXMPP.hs index adeb7455..2071ae9e 100644 --- a/ToxToXMPP.hs +++ b/ToxToXMPP.hs @@ -159,7 +159,7 @@ data Moot v = Moot data NNS a b c = NNS { -- NetcryptoNegotiationState sessionDesired :: Bool, theirPublicKey :: a Tox.DHTPublicKey, - theirAddress :: b SockAddr, + theirAddress :: b NodeInfo, theirCookie :: c (Tox.Cookie Encrypted), sessionIsActive :: Bool } @@ -172,7 +172,7 @@ data NS | Stage5 (NNS Acquired Acquired Acquired) gotDhtPubkey :: Tox.DHTPublicKey -> ToxToXMPP -> PublicKey -> IO () -gotDhtPubkey pubkey tx theirKey = do +gotDhtPubkey theirDhtKey tx theirKey = do contact <- atomically $ getContact theirKey (txAccount tx) >>= mapM (readTVar . contactLastSeenAddr) forM_ contact $ \lastSeen -> do case lastSeen of @@ -188,33 +188,13 @@ gotDhtPubkey pubkey tx theirKey = do me = key2id myPublicKey doSearch = do - akey <- akeyConnect (txAnnouncer tx) me theirKey + let akey = akeyConnect (txAnnouncer tx) me theirKey atomically $ registerNodeCallback (toxRouting tox) (nic akey) - scheduleSearch (txAnnouncer tx) akey meth pubkey - - byAddr :: TVar (Map.Map SockAddr Tox.NetCryptoSession) - byAddr = Tox.netCryptoSessions (toxCryptoSessions tox) - - crypto = Tox.transportCrypto $ toxCryptoSessions tox - - readNcVar :: (Tox.NetCryptoSession -> TVar b) -> SockAddr -> STM (Maybe b) - readNcVar v addr = traverse readTVar =<< fmap v . Map.lookup addr <$> readTVar byAddr - - chillSesh :: SockAddr -> STM (Maybe (Status Tox.ToxProgress)) - chillSesh = readNcVar Tox.ncState - - activeSesh :: SockAddr -> STM Bool - activeSesh a = chillSesh a >>= return . \case - Just Established -> True - _ -> False - - readCookie :: SockAddr -> STM (Maybe (UponCookie (Tox.Cookie Encrypted))) - readCookie = readNcVar Tox.ncCookie - readCookie' :: SockAddr -> STM (Maybe (Tox.Cookie Encrypted)) - readCookie' = fmap join . (fmap.fmap) Tox.toMaybe . readCookie + scheduleSearch (txAnnouncer tx) akey meth theirDhtKey target :: NodeId - target = key2id $ dhtpk pubkey + target = key2id $ dhtpk theirDhtKey + meth :: SearchMethod Tox.DHTPublicKey meth = SearchMethod @@ -232,9 +212,6 @@ gotDhtPubkey pubkey tx theirKey = do , rumoredAddress = assume akey } - client :: Network.Tox.DHT.Handlers.Client - client = toxDHT tox - assume :: AnnounceKey -> POSIXTime -> SockAddr -> NodeInfo -> STM () assume akey time addr ni = tput XNodeinfoSearch $ show ("rumor", akey, time, addr, ni) @@ -242,17 +219,54 @@ gotDhtPubkey pubkey tx theirKey = do observe :: AnnounceKey -> POSIXTime -> NodeInfo -> STM () observe akey time ni@(nodeAddr -> addr) = do tput XNodeinfoSearch $ show ("observation", akey, time, addr) + setContactAddr time theirKey ni (txAccount tx) + +gotAddr :: NodeInfo -> ToxToXMPP -> PublicKey -> IO () +gotAddr ni@(nodeAddr -> addr) tx theirKey = do + dhtkey <- (fmap.fmap) snd $ + fmap join $ + atomically $ + traverse readTVar =<< fmap contactKeyPacket <$> getContact theirKey (txAccount tx) + forM_ dhtkey $ gotAddr' ni tx theirKey + +gotAddr' :: NodeInfo -> ToxToXMPP -> PublicKey -> Tox.DHTPublicKey -> IO () +gotAddr' ni@(nodeAddr -> addr) tx theirKey theirDhtKey = atomically blee + + where + myPublicKey = toPublic $ userSecret (txAccount tx) + me = key2id myPublicKey + akey = akeyConnect (txAnnouncer tx) me theirKey + + blee = do + scheduleImmediately (txAnnouncer tx) akey $ + ScheduledItem $ getCookie ni (activeSesh addr) (getContact theirKey (txAccount tx)) + + tox :: Tox JabberClients + tox = txTox tx + + byAddr :: TVar (Map.Map SockAddr Tox.NetCryptoSession) + byAddr = Tox.netCryptoSessions (toxCryptoSessions tox) + + crypto = Tox.transportCrypto $ toxCryptoSessions tox + + readNcVar :: (Tox.NetCryptoSession -> TVar b) -> SockAddr -> STM (Maybe b) + readNcVar v addr = traverse readTVar =<< fmap v . Map.lookup addr <$> readTVar byAddr - contact <- getContact theirKey (txAccount tx) - join <$> traverse (readTVar . contactLastSeenAddr) contact >>= \case - -- Don't update address if we already have one from the last minute. - -- Really we need to be collecting a list of these. :-( - Just (t, addr') | addr == addr' && time - t < 60 -> return () - _ -> do + chillSesh :: SockAddr -> STM (Maybe (Status Tox.ToxProgress)) + chillSesh = readNcVar Tox.ncState + + activeSesh :: SockAddr -> STM Bool + activeSesh a = chillSesh a >>= return . \case + Just Established -> True + _ -> False - scheduleImmediately (txAnnouncer tx) akey $ - ScheduledItem $ getCookie ni (activeSesh addr) (getContact theirKey (txAccount tx)) - setContactAddr time theirKey addr (txAccount tx) + readCookie :: SockAddr -> STM (Maybe (UponCookie (Tox.Cookie Encrypted))) + readCookie = readNcVar Tox.ncCookie + readCookie' :: SockAddr -> STM (Maybe (Tox.Cookie Encrypted)) + readCookie' = fmap join . (fmap.fmap) Tox.toMaybe . readCookie + + client :: Network.Tox.DHT.Handlers.Client + client = toxDHT tox getCookie :: NodeInfo @@ -265,6 +279,7 @@ gotDhtPubkey pubkey tx theirKey = do getCookie ni isActive getC ann akey now = getCookieAgain where getCookieAgain = do + tput XNodeinfoSearch $ show ("getCookieAgain", akey) mbContact <- getC case mbContact of Nothing -> return $ return () @@ -272,7 +287,7 @@ gotDhtPubkey pubkey tx theirKey = do active <- isActive return $ when (not active) getCookieIO - callRealShakeHands = realShakeHands (userSecret (txAccount tx)) theirKey (dhtpk pubkey) (toxCryptoSessions tox) (nodeAddr ni) + callRealShakeHands = realShakeHands (userSecret (txAccount tx)) theirKey (dhtpk theirDhtKey) (toxCryptoSessions tox) (nodeAddr ni) reschedule n f = scheduleRel ann akey f n reschedule' n f = reschedule n (ScheduledItem $ \_ _ now -> f now) @@ -281,6 +296,7 @@ gotDhtPubkey pubkey tx theirKey = do getCookieIO :: IO () getCookieIO = do + dput XUnused "getCookieIO - entered" cookieRequest crypto client myPublicKey ni >>= \case Nothing -> atomically $ reschedule' 5 (const getCookieAgain) Just cookie -> do @@ -288,15 +304,21 @@ gotDhtPubkey pubkey tx theirKey = do cookieCreationStamp <- getPOSIXTime let shaker :: POSIXTime -> STM (IO ()) shaker now = do - if (now > cookieCreationStamp + cookieMaxAge) - then return $ dput XUnused "getCookieIO" - else do - reschedule' 5 shaker - return . void $ callRealShakeHands cookie + active <- isActive + if (active) + then return $ return () + else if (now > cookieCreationStamp + cookieMaxAge) + then return $ + dput XUnused "getCookieIO/shaker - cookie expired" >> + getCookieIO + else do + reschedule' 5 shaker + return . void $ callRealShakeHands cookie atomically $ reschedule' 5 shaker realShakeHands :: SecretKey -> PublicKey -> PublicKey -> Tox.NetCryptoSessions -> SockAddr -> Tox.Cookie Encrypted -> IO Bool realShakeHands myseckey theirpubkey theirDhtKey allsessions saddr cookie = do + dput XUnused "realShakeHands" let hp = HParam { hpOtherCookie = cookie @@ -318,7 +340,7 @@ realShakeHands myseckey theirpubkey theirDhtKey allsessions saddr cookie = do dispatch :: ToxToXMPP -> ContactEvent -> IO () dispatch tx (SessionEstablished theirKey) = stopConnecting tx theirKey dispatch tx (SessionTerminated theirKey) = startConnecting tx theirKey -dispatch tx (AddrChange theirkey saddr) = return () -- todo +dispatch tx (AddrChange theirKey saddr) = gotAddr saddr tx theirKey dispatch tx (PolicyChange theirkey TryingToConnect ) = startConnecting tx theirkey dispatch tx (PolicyChange theirkey policy ) = stopConnecting tx theirkey dispatch tx (OnionRouted theirKey (OnionDHTPublicKey pkey)) = gotDhtPubkey pkey tx theirKey @@ -352,12 +374,12 @@ interweave :: [a] -> [a] -> [a] interweave [] ys = ys interweave (x:xs) ys = x : interweave ys xs -akeyDHTKeyShare :: Announcer -> NodeId -> PublicKey -> IO AnnounceKey -akeyDHTKeyShare announcer me them = atomically $ do +akeyDHTKeyShare :: Announcer -> NodeId -> PublicKey -> AnnounceKey +akeyDHTKeyShare announcer me them = packAnnounceKey announcer $ "dhtkey:" ++ (take 8 $ show me) ++ ":" ++ show (key2id them) -akeyConnect :: Announcer -> NodeId -> PublicKey -> IO AnnounceKey -akeyConnect announcer me them = atomically $ do +akeyConnect :: Announcer -> NodeId -> PublicKey -> AnnounceKey +akeyConnect announcer me them = packAnnounceKey announcer $ "connect:" ++ (take 8 $ show me) ++ ":" ++ show (key2id them) @@ -407,7 +429,7 @@ startConnecting0 tx them contact = do me = key2id mypub soliciting <- checkSoliciting (txPresence tx) mypub them contact when wanted $ do - akey <- akeyDHTKeyShare announcer me them + akey <- return $ akeyDHTKeyShare announcer me them -- We send this packet every 30 seconds if there is more -- than one peer (in the 8) that says they our friend is -- announced on them. This packet can also be sent through @@ -464,9 +486,9 @@ startConnecting tx them = do stopConnecting :: ToxToXMPP -> PublicKey -> IO () stopConnecting ToxToXMPP{txAnnouncer=announcer,txAccount=acnt} them = do dput XMan $ "STOP CONNECTING " ++ show (key2id them) - let pub = toPublic $ userSecret acnt - me = key2id pub - akey <- akeyDHTKeyShare announcer me them + let pub = toPublic $ userSecret acnt + me = key2id pub + akey = akeyDHTKeyShare announcer me them cancel announcer akey forkAccountWatcher :: Account JabberClients -> Tox JabberClients -> PresenceState -> Announcer -> IO ThreadId diff --git a/examples/dhtd.hs b/examples/dhtd.hs index c03df3cc..9b5abb22 100644 --- a/examples/dhtd.hs +++ b/examples/dhtd.hs @@ -1065,7 +1065,7 @@ clientSession s@Session{..} sock cnum h = do rs <- atomically $ do as <- scheduleToList announcer forM (as) $ \(k,ptm,item) -> do - kstr <- unpackAnnounceKey announcer k + let kstr = unpackAnnounceKey announcer k return [ if ptm==0 then "now" else show (ptm - now) , show (itemStatusNum item) @@ -1124,7 +1124,7 @@ clientSession s@Session{..} sock cnum h = do -- return $ hPutClient h "Type matches." dta <- either (const Nothing) Just $ announceParseData dtastr return $ do - akey <- atomically $ packAnnounceKey announcer (method ++ ":" ++ dtastr) + let akey = packAnnounceKey announcer (method ++ ":" ++ dtastr) doitR op announcer akey (AnnounceMethod qsearch asend @@ -1150,7 +1150,7 @@ clientSession s@Session{..} sock cnum h = do dta <- either (const Nothing) Just $ announceParseData dtastr pub <- selectedKey return $ do - akey <- atomically $ packAnnounceKey announcer (method ++ ":" ++ dtastr) + let akey = packAnnounceKey announcer (method ++ ":" ++ dtastr) doitL op announcer akey (SearchMethod qsearch (asend pub) @@ -1352,7 +1352,7 @@ netcrypto (Just (DHT {..})) (Just mypubkey) h roster (Just tox) exes paramStr = Nothing -> hPutClient h "Unable to find account for selected key" Just account -> do now <- getPOSIXTime - atomically $ setContactAddr now their_pub their_addr account + atomically $ setContactAddr now their_pub (_fixme their_addr) account sessions <- Tox.netCrypto tox sec their_pub exeDir <- takeDirectory <$> getExecutablePath forM_ sessions $ \session -> do diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs index f7cf7b1e..cebbebfb 100644 --- a/src/Network/Tox.hs +++ b/src/Network/Tox.hs @@ -261,7 +261,7 @@ netCryptoWithBackoff millisecs tox myseckey theirpubkey = do -- Convert to NodeInfo, so we can send cookieRequest let crypto = toxCryptoKeys tox client = toxDHT tox - case nodeInfo (key2id theirDhtKey) saddr of + case nodeInfo (key2id theirDhtKey) (nodeAddr saddr) of Left e -> dput XNetCrypto ("netCrypto: nodeInfo fail... " ++ e) >> return [] Right ni -> do mbCookie <- DHT.cookieRequest crypto client (toPublic myseckey) ni @@ -282,11 +282,11 @@ netCryptoWithBackoff millisecs tox myseckey theirpubkey = do newsession <- generateSecretKey timestamp <- getPOSIXTime (myhandshake,ioAction) - <- atomically $ freshCryptoSession (toxCryptoSessions tox) saddr newsession timestamp hp + <- atomically $ freshCryptoSession (toxCryptoSessions tox) (nodeAddr saddr) newsession timestamp hp ioAction -- send handshake forM myhandshake $ \response_handshake -> do - sendHandshake (toxCryptoSessions tox) saddr response_handshake + sendHandshake (toxCryptoSessions tox) (nodeAddr saddr) response_handshake let secnum :: Double secnum = fromIntegral millisecs / 1000000 delay = (millisecs * 5 `div` 4) diff --git a/src/Network/Tox/ContactInfo.hs b/src/Network/Tox/ContactInfo.hs index 3f794197..1970b782 100644 --- a/src/Network/Tox/ContactInfo.hs +++ b/src/Network/Tox/ContactInfo.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE LambdaCase #-} module Network.Tox.ContactInfo where import Connection @@ -30,13 +31,13 @@ data Account extra = Account data ContactEvent = OnionRouted { contact :: PublicKey, onionRouted :: OnionData } | PolicyChange { contact :: PublicKey, policyChange :: Policy } - | AddrChange { contact :: PublicKey, addrChange :: SockAddr } + | AddrChange { contact :: PublicKey, addrChange :: NodeInfo } | SessionEstablished { contact :: PublicKey } | SessionTerminated { contact :: PublicKey } data Contact = Contact { contactKeyPacket :: TVar (Maybe (POSIXTime,DHT.DHTPublicKey)) - , contactLastSeenAddr :: TVar (Maybe (POSIXTime,SockAddr)) + , contactLastSeenAddr :: TVar (Maybe (POSIXTime,NodeInfo)) , contactFriendRequest :: TVar (Maybe (POSIXTime,DHT.FriendRequest)) , contactPolicy :: TVar (Maybe Connection.Policy) } @@ -97,7 +98,7 @@ onionUpdate now (Onion.OnionFriendRequest fr) contact policyUpdate :: Policy -> Contact -> STM () policyUpdate policy contact = writeTVar (contactPolicy contact) $ Just policy -addrUpdate :: POSIXTime -> SockAddr -> Contact -> STM () +addrUpdate :: POSIXTime -> NodeInfo -> Contact -> STM () addrUpdate now addr contact = writeTVar (contactLastSeenAddr contact) $ Just (now,addr) setContactPolicy :: PublicKey -> Policy -> Account extra -> STM () @@ -105,10 +106,16 @@ setContactPolicy remoteUserKey policy acc = do updateAccount' remoteUserKey acc $ policyUpdate policy writeTChan (eventChan acc) $ PolicyChange remoteUserKey policy -setContactAddr :: POSIXTime -> PublicKey -> SockAddr -> Account extra -> STM () +setContactAddr :: POSIXTime -> PublicKey -> NodeInfo -> Account extra -> STM () setContactAddr now remoteUserKey addr acc = do - updateAccount' remoteUserKey acc $ addrUpdate now addr - writeTChan (eventChan acc) $ AddrChange remoteUserKey addr + contact <- getContact remoteUserKey acc + let update = updateAccount' remoteUserKey acc $ addrUpdate now addr + let notify = writeTChan (eventChan acc) $ AddrChange remoteUserKey addr + join <$> traverse (readTVar . contactLastSeenAddr) contact >>= \case + Just (_, a) | addr == a -> update -- updates time only + Just (t, _) | now > t + 60 -> update >> notify -- update IP if existing one is old + Nothing -> update >> notify -- or if we don't have any + _ -> return () -- otherwise just wait setEstablished :: POSIXTime -> PublicKey -> Account extra -> STM () setEstablished now remoteUserKey acc = -- cgit v1.2.3