From 3433bee9e382b650a924d60502f9286a850568d0 Mon Sep 17 00:00:00 2001 From: James Crayne Date: Thu, 31 May 2018 04:38:17 +0000 Subject: NetCrypto TVars patch: * Change UponHandshake values in NetCryptoSession to TVars * factor freshCryptoSession, new functions: runUponHandshake createNetCryptoOutQueue * Try to handle intitated vs uninitiated sessions better (modifications to updateCryptoSession) --- src/Network/Tox/Crypto/Handlers.hs | 144 +++++++++++++++++++++++-------------- 1 file changed, 91 insertions(+), 53 deletions(-) (limited to 'src/Network/Tox/Crypto') diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs index bde286fe..0027e414 100644 --- a/src/Network/Tox/Crypto/Handlers.hs +++ b/src/Network/Tox/Crypto/Handlers.hs @@ -225,7 +225,7 @@ data NetCryptoSession = NCrypto , ncHandShake :: TVar (UponHandshake (Handshake Encrypted)) , ncCookie :: TVar (UponCookie Cookie) -- ^ Cookie issued by remote peer , ncTheirDHTKey :: UponDHTKey PublicKey - , ncTheirSessionPublic :: UponHandshake PublicKey + , ncTheirSessionPublic :: TVar (UponHandshake PublicKey) , ncSessionSecret :: SecretKey , ncSockAddr :: UponDHTKey SockAddr -- The remaining fields correspond to implementation specific state -- @@ -550,22 +550,14 @@ freshCryptoSession sessions mbpktoq <- case mbtheirSessionKey of Nothing -> return NeedHandshake - Just theirSessionKey -> do - let toWireIO = do - f <- lookupNonceFunction crypto newsession theirSessionKey - atomically $ do - n24 <- readTVar ncMyPacketNonce0 - let n24plus1 = incrementNonce24 n24 - trace ("ncMyPacketNonce+1=" ++ show n24plus1) $ writeTVar ncMyPacketNonce0 n24plus1 - return (return (f n24, n24, ncOutgoingIdMap0)) - pktoq <- atomically $ PQ.newOutGoing pktq ncToWire toWireIO 0 (outboundQueueCapacity sessions) 0 - return (HaveHandshake pktoq) + Just theirSessionKey -> createNetCryptoOutQueue sessions newsession theirSessionKey pktq ncMyPacketNonce0 ncOutgoingIdMap0 lastNQ <- atomically (CB.new 10 0 :: STM (CyclicBuffer (Bool,(ViewSnapshot,InOrOut CryptoMessage)))) listeners <- atomically $ newTVar IntMap.empty msgNum <- atomically $ newTVar 0 dropNum <- atomically $ newTVar 0 theirbasenonce <- atomically $ readTVar ncTheirBaseNonce0 dput XNetCrypto $ "freshCryptoSession: Session ncTheirBaseNonce=" ++ show theirbasenonce + ncTheirSessionPublic0 <- atomically $ newTVar (frmMaybe mbtheirSessionKey) let netCryptoSession0 = NCrypto { ncState = ncState0 , ncMyPublicKey = toPublic key @@ -576,7 +568,7 @@ freshCryptoSession sessions , ncHandShake = ncHandShake0 , ncCookie = cookie0 , ncTheirDHTKey = HaveDHTKey remoteDhtPublicKey - , ncTheirSessionPublic = frmMaybe mbtheirSessionKey + , ncTheirSessionPublic = ncTheirSessionPublic0 , ncSessionSecret = newsession , ncSockAddr = HaveDHTKey addr , ncHooks = ncHooks0 @@ -594,7 +586,40 @@ freshCryptoSession sessions , ncLastNMsgs = lastNQ , ncListeners = listeners } + case mbpktoq of + NeedHandshake -> return () + HaveHandshake pktoq -> runUponHandshake netCryptoSession0 addr pktoq + +type NetCryptoOutQueue = PQ.PacketOutQueue (State,Nonce24,RangeMap TArray Word8 TVar) + CryptoMessage + (CryptoPacket Encrypted) + CryptoData + +createNetCryptoOutQueue :: NetCryptoSessions -> SecretKey -> PublicKey -> PacketQueue CryptoData + -> TVar Nonce24 -> RangeMap TArray Word8 TVar -> IO (UponHandshake NetCryptoOutQueue) +createNetCryptoOutQueue sessions newsession theirSessionKey pktq ncMyPacketNonce0 ncOutgoingIdMap0 = do + let crypto = transportCrypto sessions + let toWireIO = do + f <- lookupNonceFunction crypto newsession theirSessionKey + atomically $ do + n24 <- readTVar ncMyPacketNonce0 + let n24plus1 = incrementNonce24 n24 + trace ("ncMyPacketNonce+1=" ++ show n24plus1) $ writeTVar ncMyPacketNonce0 n24plus1 + return (return (f n24, n24, ncOutgoingIdMap0)) + pktoq <- atomically $ PQ.newOutGoing pktq ncToWire toWireIO 0 (outboundQueueCapacity sessions) 0 + return (HaveHandshake pktoq) + + +runUponHandshake :: NetCryptoSession -> SockAddr -> NetCryptoOutQueue -> IO () +runUponHandshake netCryptoSession0 addr pktoq = do + let sessions = ncAllSessions netCryptoSession0 + pktq = ncPacketQueue netCryptoSession0 + remotePublicKey = ncTheirPublicKey netCryptoSession0 + crypto = transportCrypto sessions + allsessions = netCryptoSessions sessions + allsessionsByKey = netCryptoSessionsByKey sessions -- launch dequeue thread + -- (In terms of data dependency, this thread could be launched prior to handshake) threadid <- forkIO $ do tid <- myThreadId labelThread tid ("NetCryptoDequeue." ++ show (key2id remotePublicKey)) @@ -602,44 +627,41 @@ freshCryptoSession sessions cd <- atomically $ PQ.dequeue pktq _ <- runCryptoHook (netCryptoSession0 {ncDequeueThread=Just tid}) (bufferData cd) loop - case mbpktoq of - NeedHandshake -> return () - HaveHandshake pktoq -> do - -- launch dequeueOutgoing thread - threadidOutgoing <- forkIO $ do - tid <- myThreadId - labelThread tid ("NetCryptoDequeueOutgoing." ++ show (key2id remotePublicKey)) - fix $ \loop -> do - (_,pkt) <- atomically $ PQ.dequeueOutgoing pktoq - dput XNetCrypto "NetCryptoDequeueOutgoing thread... Sending encrypted Packet" - sendMessage (sessionTransport sessions) addr (NetCrypto pkt) - loop - -- launch ping thread - fuzz <- randomRIO (0,2000) - pingMachine <- forkPingMachine ("NetCrypto." ++ show (key2id remotePublicKey)) (15000 + fuzz) 2000 - -- update session with thread ids - let netCryptoSession = netCryptoSession0 {ncDequeueThread=Just threadid, ncPingMachine=Just pingMachine} - -- add this session to the lookup maps - atomically $ do - modifyTVar allsessions (Map.insert addr netCryptoSession) - byKeyResult <- readTVar allsessionsByKey >>= return . Map.lookup remotePublicKey - case byKeyResult of - Nothing -> modifyTVar allsessionsByKey (Map.insert remotePublicKey [netCryptoSession]) - Just xs -> modifyTVar allsessionsByKey (Map.insert remotePublicKey (netCryptoSession:xs)) - -- run announceNewSessionHooks - hooks <- atomically $ readTVar (announceNewSessionHooks sessions) - flip fix (hooks,netCryptoSession) $ \loop (hooks,session) -> - case hooks of - [] -> return () - (h:hs) -> do - r <- h Nothing session - case r of - Just f -> loop (hs, f session) - Nothing -> return () + -- launch dequeueOutgoing thread + threadidOutgoing <- forkIO $ do + tid <- myThreadId + labelThread tid ("NetCryptoDequeueOutgoing." ++ show (key2id remotePublicKey)) + fix $ \loop -> do + (_,pkt) <- atomically $ PQ.dequeueOutgoing pktoq + dput XNetCrypto "NetCryptoDequeueOutgoing thread... Sending encrypted Packet" + sendMessage (sessionTransport sessions) addr (NetCrypto pkt) + loop + -- launch ping thread + fuzz <- randomRIO (0,2000) + pingMachine <- forkPingMachine ("NetCrypto." ++ show (key2id remotePublicKey)) (15000 + fuzz) 2000 + -- update session with thread ids + let netCryptoSession = netCryptoSession0 {ncDequeueThread=Just threadid, ncPingMachine=Just pingMachine} + -- add this session to the lookup maps + atomically $ do + modifyTVar allsessions (Map.insert addr netCryptoSession) + byKeyResult <- readTVar allsessionsByKey >>= return . Map.lookup remotePublicKey + case byKeyResult of + Nothing -> modifyTVar allsessionsByKey (Map.insert remotePublicKey [netCryptoSession]) + Just xs -> modifyTVar allsessionsByKey (Map.insert remotePublicKey (netCryptoSession:xs)) + -- run announceNewSessionHooks + hooks <- atomically $ readTVar (announceNewSessionHooks sessions) + flip fix (hooks,netCryptoSession) $ \loop (hooks,session) -> + case hooks of + [] -> return () + (h:hs) -> do + r <- h Nothing session + case r of + Just f -> loop (hs, f session) + Nothing -> return () -- | Called when we get a handshake, but there's already a session entry. -updateCryptoSession :: NetCryptoSessions -> SockAddr -> HandshakeParams -> NetCryptoSession -> IO () -updateCryptoSession sessions addr hp session = do +updateCryptoSession :: NetCryptoSessions -> SockAddr -> HandshakeParams -> NetCryptoSession -> Handshake Encrypted -> IO () +updateCryptoSession sessions addr hp session handshake = do ncState0 <- atomically $ readTVar (ncState session) ncTheirBaseNonce0 <- atomically $ readTVar (ncTheirBaseNonce session) if (ncState0 >= {-Accepted-}InProgress AwaitingSessionPacket) @@ -656,10 +678,25 @@ updateCryptoSession sessions addr hp session = do dput XNetCrypto (" ncTheirDHTKey=" ++ show (ncTheirDHTKey session) ++ bool "{/=}" "{==}" (ncTheirDHTKey session == HaveDHTKey (hpCookieRemoteDhtkey hp)) ++ "hpCookieRemoteDhtkey=" ++ show (hpCookieRemoteDhtkey hp)) - when ( -- Just ncTheirBaseNonce0 /= hpTheirBaseNonce hp -- XXX: Do we really want to compare base nonce here? + if ( -- Just ncTheirBaseNonce0 /= hpTheirBaseNonce hp -- XXX: Do we really want to compare base nonce here? -- || ncTheirDHTKey session /= HaveDHTKey (hpCookieRemoteDhtkey hp) - ) $ freshCryptoSession sessions addr hp + ) then freshCryptoSession sessions addr hp + else do + atomically $ do + writeTVar (ncTheirBaseNonce session) (frmMaybe (hpTheirBaseNonce hp)) + writeTVar (ncTheirSessionPublic session) (frmMaybe (hpTheirSessionKeyPublic hp)) + writeTVar (ncHandShake session) (HaveHandshake handshake) + case ncOutgoingQueue session of + NeedHandshake -> do + case hpTheirSessionKeyPublic hp of + Just sessionpubkey -> do + pktoq <- createNetCryptoOutQueue sessions (ncSessionSecret session) sessionpubkey + (ncPacketQueue session) (ncMyPacketNonce session) (ncOutgoingIdMap session) + case pktoq of + NeedHandshake -> dput XNetCrypto "Unexpectedly missing ncOutgoingQueue" + HaveHandshake pktoq -> runUponHandshake session addr pktoq + HaveHandshake pktoq -> runUponHandshake session addr pktoq else do dput XNetCrypto "updateCryptoSession else clause" dput XNetCrypto (" ncTheirBaseNonce0=" ++ show ncTheirBaseNonce0 @@ -674,7 +711,7 @@ cryptoNetHandler sessions addr (NetHandshake hs) = handshakeH sessions addr cryptoNetHandler sessions addr (NetCrypto pkt) = sessionPacketH sessions addr pkt handshakeH :: NetCryptoSessions -> SockAddr -> Handshake Encrypted -> IO (Maybe a) -handshakeH sessions addr (Handshake (Cookie n24 ecookie) nonce24 encrypted) = do +handshakeH sessions addr hshake@(Handshake (Cookie n24 ecookie) nonce24 encrypted) = do dput XNetCrypto ("RECIEVED HANDSHAKE from " ++ show addr) -- Handle Handshake Message let crypto = transportCrypto sessions @@ -746,7 +783,7 @@ handshakeH sessions addr (Handshake (Cookie n24 ecookie) nonce24 encrypted) = do freshCryptoSession sessions addr hp -- create new session Just session -> do dput XNetCrypto "sockaddr ALREADY in session map, so updateCryptoSession" - updateCryptoSession sessions addr hp session -- update existing session + updateCryptoSession sessions addr hp session hshake -- update existing session return Nothing sessionPacketH :: NetCryptoSessions -> SockAddr -> CryptoPacket Encrypted -> IO (Maybe (x -> x)) @@ -771,8 +808,9 @@ sessionPacketH sessions addr (CryptoPacket nonce16 encrypted) = do let diff :: Word16 diff = nonce16 - (last2Bytes theirBaseNonce) -- truncating to Word16 tempNonce = addtoNonce24 theirBaseNonce (fromIntegral diff) -- expanding to Word + mbpublickey <- atomically (readTVar ncTheirSessionPublic) lr <- fmap join $ sequence $ do -- Either Monad -- - pubkey <- maybeToEither ncTheirSessionPublic + pubkey <- maybeToEither mbpublickey Right $ do -- IO Monad dput XNetCrypto $ "cryptoNetHandler: pubkey = " ++ show (key2id $ pubkey) dput XNetCrypto $ "cryptoNetHandler: theirBaseNonce = " ++ show theirBaseNonce -- cgit v1.2.3