From 5edbd08b22598310839bb2ad4a779fc70c5c54b8 Mon Sep 17 00:00:00 2001 From: James Crayne Date: Thu, 31 May 2018 15:54:51 +0000 Subject: {fresh,update}CryptoSession are now in STM --- src/Network/Tox/Crypto/Handlers.hs | 210 ++++++++++++++++++------------------- 1 file changed, 103 insertions(+), 107 deletions(-) (limited to 'src/Network/Tox/Crypto/Handlers.hs') diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs index eabbc9b0..722d8507 100644 --- a/src/Network/Tox/Crypto/Handlers.hs +++ b/src/Network/Tox/Crypto/Handlers.hs @@ -7,7 +7,7 @@ module Network.Tox.Crypto.Handlers where import Network.Tox.NodeId import Network.Tox.Crypto.Transport import Network.Tox.DHT.Transport (Cookie(..),CookieData(..), CookieRequest(..), NoSpam(..)) -import Network.Tox.DHT.Handlers (Client, cookieRequest, createCookie ) +import Network.Tox.DHT.Handlers (Client, cookieRequest, createCookieSTM ) import Crypto.Tox import Control.Arrow import Control.Concurrent.STM @@ -395,25 +395,18 @@ data HandshakeParams , hpCookieRemoteDhtkey :: PublicKey } -newHandShakeData :: TransportCrypto -> Nonce24 -> HandshakeParams -> SockAddr -> PublicKey -> IO (Maybe HandshakeData) -newHandShakeData crypto basenonce (HParam {hpOtherCookie,hpMySecretKey,hpCookieRemotePubkey,hpCookieRemoteDhtkey}) addr mySessionPublic +newHandShakeData :: POSIXTime -> TransportCrypto -> Nonce24 -> HandshakeParams -> SockAddr -> PublicKey -> STM (Maybe HandshakeData) +newHandShakeData timestamp crypto basenonce (HParam {hpOtherCookie,hpMySecretKey,hpCookieRemotePubkey,hpCookieRemoteDhtkey}) addr mySessionPublic = do freshCookie <- case nodeInfo (key2id hpCookieRemoteDhtkey) addr of - Right nodeinfo -> Just <$> createCookie crypto nodeinfo hpCookieRemotePubkey + Right nodeinfo -> Just <$> createCookieSTM timestamp crypto nodeinfo hpCookieRemotePubkey Left er -> return Nothing let hinit = hashInit Cookie n24 encrypted = hpOtherCookie hctx = hashUpdate hinit n24 hctx' = hashUpdate hctx encrypted digest = hashFinalize hctx' --- parameters addr {--> SockAddr -} --- mbcookie <- case hpOtherCookie of --- Nothing -> case (nodeInfo hpCookieRemoteDhtkey addr) of --- Right nodeinfo -> cookieRequest crypto netCryptoDHTClient (toPublic hpMySecretKey) nodeinfo --- Left er -> return Nothing --- Just c -> return (Just c) - return $ fmap (\freshCookie' -> HandshakeData @@ -489,9 +482,11 @@ ncToWire getState seqno bufend pktno msg = do -- then increment it regardless. (Keep addr in MinMaxPSQ in Roster.Contact) -- -- This function sends a handshake response packet. -freshCryptoSession :: NetCryptoSessions -> SockAddr -> HandshakeParams -> IO () +freshCryptoSession :: NetCryptoSessions -> SockAddr -> SecretKey -> POSIXTime -> HandshakeParams -> STM (Maybe (Handshake Encrypted),IO ()) freshCryptoSession sessions addr + newsession + timestamp hp@(HParam { hpTheirBaseNonce = mbtheirBaseNonce , hpOtherCookie = otherCookie @@ -503,20 +498,20 @@ freshCryptoSession sessions let crypto = transportCrypto sessions allsessions = netCryptoSessions sessions allsessionsByKey = netCryptoSessionsByKey sessions - sessionId <- atomically $ do + dmsg msg = trace msg (return ()) + sessionId <- do x <- readTVar (nextSessionId sessions) modifyTVar (nextSessionId sessions) (+1) return x - -- ncState0 <- atomically $ newTVar Accepted -- (InProgress AwaitingSessionPacket) - ncState0 <- atomically $ newTVar (if isJust mbtheirBaseNonce + -- ncState0 <- newTVar Accepted -- (InProgress AwaitingSessionPacket) + ncState0 <- newTVar (if isJust mbtheirBaseNonce then InProgress AwaitingSessionPacket else InProgress AwaitingHandshake) - ncTheirBaseNonce0 <- atomically $ newTVar (frmMaybe mbtheirBaseNonce) - n24 <- atomically $ transportNewNonce crypto - state <- lookupSharedSecret crypto key remotePublicKey n24 - newBaseNonce <- atomically $ transportNewNonce crypto - newsession <- generateSecretKey - mbMyhandshakeData <- newHandShakeData crypto newBaseNonce hp addr (toPublic newsession) + ncTheirBaseNonce0 <- newTVar (frmMaybe mbtheirBaseNonce) + n24 <- transportNewNonce crypto + state <- ($ n24) <$> lookupNonceFunctionSTM timestamp crypto key remotePublicKey + newBaseNonce <- transportNewNonce crypto + mbMyhandshakeData <- newHandShakeData timestamp crypto newBaseNonce hp addr (toPublic newsession) let encodeHandshake myhandshakeData = let plain = encodePlain myhandshakeData -- state = computeSharedSecret key remoteDhtPublicKey n24 encrypted = encrypt state plain @@ -525,16 +520,14 @@ freshCryptoSession sessions , handshakeData = encrypted } let myhandshake= encodeHandshake <$> mbMyhandshakeData - ncHandShake0 <- atomically $ newTVar (frmMaybe myhandshake) - forM myhandshake $ \response_handshake -> do - sendHandshake sessions addr response_handshake - ncMyPacketNonce0 <- atomically $ newTVar newBaseNonce - cookie0 <- atomically $ newTVar (HaveCookie otherCookie) - ncHooks0 <- atomically $ newTVar (defaultHooks sessions) - ncUnrecognizedHook0 <- atomically $ newTVar (defaultUnrecognizedHook sessions) - ncIncomingTypeArray0 <- atomically $ newTVar (msgTypeArray sessions) + ncHandShake0 <- newTVar (frmMaybe myhandshake) + ncMyPacketNonce0 <- newTVar newBaseNonce + cookie0 <- newTVar (HaveCookie otherCookie) + ncHooks0 <- newTVar (defaultHooks sessions) + ncUnrecognizedHook0 <- newTVar (defaultUnrecognizedHook sessions) + ncIncomingTypeArray0 <- newTVar (msgTypeArray sessions) let idMap = foldl (\mp (x,y) -> W64.insert x y mp) W64.empty (zip [0..255] [0..255]) - (ncOutgoingIdMap0,lossyEscapeIdMap,losslessEscapeIdMap) <- atomically $ do + (ncOutgoingIdMap0,lossyEscapeIdMap,losslessEscapeIdMap) <- do idmap <- emptySTMRangeMap insertArrayAt idmap 0 (A.listArray (0,255) [0 .. 255]) -- the 2 escape ranges are adjacent, so put them in one array: @@ -546,21 +539,21 @@ freshCryptoSession sessions lossyEsc <- newTVar $ A.listArray (0,255) [0 .. 255] losslessEsc <- newTVar $ A.listArray (0,255) [0 .. 255] return (idmap,lossyEsc,losslessEsc) - ncView0 <- atomically $ newTVar (sessionView sessions) - pktq <- atomically $ PQ.new (inboundQueueCapacity sessions) 0 - bufstart <- atomically $ newTVar 0 + ncView0 <- newTVar (sessionView sessions) + pktq <- PQ.new (inboundQueueCapacity sessions) 0 + bufstart <- newTVar 0 mbpktoq <- case mbtheirSessionKey of Nothing -> return NeedHandshake 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 - dput XNetCrypto $ "freshCryptoSession: My Session Public =" ++ show (key2id $ toPublic newsession) - ncTheirSessionPublic0 <- atomically $ newTVar (frmMaybe mbtheirSessionKey) + lastNQ <- CB.new 10 0 :: STM (CyclicBuffer (Bool,(ViewSnapshot,InOrOut CryptoMessage))) + listeners <- newTVar IntMap.empty + msgNum <- newTVar 0 + dropNum <- newTVar 0 + theirbasenonce <- readTVar ncTheirBaseNonce0 + dmsg $ "freshCryptoSession: Session ncTheirBaseNonce=" ++ show theirbasenonce + dmsg $ "freshCryptoSession: My Session Public =" ++ show (key2id $ toPublic newsession) + ncTheirSessionPublic0 <- newTVar (frmMaybe mbtheirSessionKey) let netCryptoSession0 = NCrypto { ncState = ncState0 , ncMyPublicKey = toPublic key @@ -590,9 +583,11 @@ freshCryptoSession sessions , ncListeners = listeners } addSessionToMapIfNotThere sessions addr netCryptoSession0 - case mbpktoq of - NeedHandshake -> return () - HaveHandshake pktoq -> runUponHandshake netCryptoSession0 addr pktoq + maybeLaunchMissles + <- case mbpktoq of + NeedHandshake -> return (return ()) + HaveHandshake pktoq -> return (runUponHandshake netCryptoSession0 addr pktoq) + return (myhandshake,maybeLaunchMissles) type NetCryptoOutQueue = PQ.PacketOutQueue (State,Nonce24,RangeMap TArray Word8 TVar) CryptoMessage @@ -600,7 +595,7 @@ type NetCryptoOutQueue = PQ.PacketOutQueue (State,Nonce24,RangeMap TArray Word8 CryptoData createNetCryptoOutQueue :: NetCryptoSessions -> SecretKey -> PublicKey -> PacketQueue CryptoData - -> TVar Nonce24 -> RangeMap TArray Word8 TVar -> IO (UponHandshake NetCryptoOutQueue) + -> TVar Nonce24 -> RangeMap TArray Word8 TVar -> STM (UponHandshake NetCryptoOutQueue) createNetCryptoOutQueue sessions newsession theirSessionKey pktq ncMyPacketNonce0 ncOutgoingIdMap0 = do let crypto = transportCrypto sessions let toWireIO = do @@ -613,33 +608,33 @@ createNetCryptoOutQueue sessions newsession theirSessionKey pktq ncMyPacketNonce ++ "\n toWireIO: my public session key = " ++ show (key2id (toPublic newsession)) ) $ writeTVar ncMyPacketNonce0 n24plus1 return (return (f n24, n24, ncOutgoingIdMap0)) - pktoq <- atomically $ PQ.newOutGoing pktq ncToWire toWireIO 0 (outboundQueueCapacity sessions) 0 + pktoq <- PQ.newOutGoing pktq ncToWire toWireIO 0 (outboundQueueCapacity sessions) 0 return (HaveHandshake pktoq) -- | add this session to the lookup maps, unless its already in them -addSessionToMapIfNotThere :: NetCryptoSessions -> SockAddr -> NetCryptoSession -> IO () +addSessionToMapIfNotThere :: NetCryptoSessions -> SockAddr -> NetCryptoSession -> STM () addSessionToMapIfNotThere sessions addr netCryptoSession = do - dput XNetCrypto $ "addSessionToMapIfNotThere sockaddr = " ++ show addr ++ ", sessionid = " ++ show (ncSessionId netCryptoSession) - atomically $ do - let remotePublicKey = ncTheirPublicKey netCryptoSession - allsessions = netCryptoSessions sessions - allsessionsByKey= netCryptoSessionsByKey sessions - byAddrResult <- readTVar allsessions >>= return . Map.lookup addr - case byAddrResult of - Just (NCrypto { ncSessionId = staleId }) -> do - -- manually remove the stale session from the by-key map - modifyTVar allsessionsByKey (Map.map (filter ((/=staleId) . ncSessionId))) - Nothing -> return () -- nothing to remove - -- write session to by-addr map regardless of whether one is in there, - -- it should overwrite on match - modifyTVar allsessions (Map.insert addr netCryptoSession) - -- Now insert new session into by-key map - byKeyResult <- readTVar allsessionsByKey >>= return . Map.lookup remotePublicKey - case byKeyResult of - Nothing -> modifyTVar allsessionsByKey (Map.insert remotePublicKey [netCryptoSession]) - Just xs -> do - -- in case we're using the same long term key on different IPs ... - modifyTVar allsessionsByKey (Map.insert remotePublicKey (netCryptoSession:xs)) + let dmsg msg = trace msg (return ()) + dmsg $ "addSessionToMapIfNotThere sockaddr = " ++ show addr ++ ", sessionid = " ++ show (ncSessionId netCryptoSession) + let remotePublicKey = ncTheirPublicKey netCryptoSession + allsessions = netCryptoSessions sessions + allsessionsByKey= netCryptoSessionsByKey sessions + byAddrResult <- readTVar allsessions >>= return . Map.lookup addr + case byAddrResult of + Just (NCrypto { ncSessionId = staleId }) -> do + -- manually remove the stale session from the by-key map + modifyTVar allsessionsByKey (Map.map (filter ((/=staleId) . ncSessionId))) + Nothing -> return () -- nothing to remove + -- write session to by-addr map regardless of whether one is in there, + -- it should overwrite on match + modifyTVar allsessions (Map.insert addr netCryptoSession) + -- Now insert new session into by-key map + byKeyResult <- readTVar allsessionsByKey >>= return . Map.lookup remotePublicKey + case byKeyResult of + Nothing -> modifyTVar allsessionsByKey (Map.insert remotePublicKey [netCryptoSession]) + Just xs -> do + -- in case we're using the same long term key on different IPs ... + modifyTVar allsessionsByKey (Map.insert remotePublicKey (netCryptoSession:xs)) runUponHandshake :: NetCryptoSession -> SockAddr -> NetCryptoOutQueue -> IO () runUponHandshake netCryptoSession0 addr pktoq = do @@ -673,7 +668,7 @@ runUponHandshake netCryptoSession0 addr pktoq = do -- update session with thread ids let netCryptoSession = netCryptoSession0 {ncDequeueThread=Just threadid, ncPingMachine=Just pingMachine} -- add this session to the lookup maps - addSessionToMapIfNotThere sessions addr netCryptoSession + -- atomically $ addSessionToMapIfNotThere sessions addr netCryptoSession -- run announceNewSessionHooks hooks <- atomically $ readTVar (announceNewSessionHooks sessions) flip fix (hooks,netCryptoSession) $ \loop (hooks,session) -> @@ -691,10 +686,12 @@ runUponHandshake netCryptoSession0 addr pktoq = do -- 2) handshake for new session (old session is lost?) -- 3) we initiated, this a response -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) +updateCryptoSession :: NetCryptoSessions -> SockAddr -> SecretKey -> POSIXTime -> HandshakeParams + -> NetCryptoSession -> Handshake Encrypted -> STM (Maybe (Handshake Encrypted), IO ()) +updateCryptoSession sessions addr newsession timestamp hp session handshake = do + let dmsg msg = trace msg (return ()) + ncState0 <- readTVar (ncState session) + ncTheirBaseNonce0 <- readTVar (ncTheirBaseNonce session) if (ncState0 >= {-Accepted-}InProgress AwaitingSessionPacket) -- If the nonce in the handshake and the dht key are both the same as -- the ones we have saved, assume we already handled this and this is a @@ -702,42 +699,31 @@ updateCryptoSession sessions addr hp session handshake = do -- refresh all state. -- then do - dput XNetCrypto "updateCryptoSession already accepted.." - dput XNetCrypto (" ncTheirBaseNonce0=" ++ show ncTheirBaseNonce0 + dmsg "updateCryptoSession already accepted.." + dmsg (" ncTheirBaseNonce0=" ++ show ncTheirBaseNonce0 ++ bool "(/=)" "(==)" (toMaybe ncTheirBaseNonce0 == hpTheirBaseNonce hp) ++ "hpTheirBaseNonce=" ++ show (hpTheirBaseNonce hp)) - dput XNetCrypto (" ncTheirDHTKey=" ++ show (ncTheirDHTKey session) + dmsg (" 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 - -- 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 + ) + then freshCryptoSession sessions addr newsession timestamp hp + else return (Nothing,return ()) else do - dput XNetCrypto "updateCryptoSession else clause" - dput XNetCrypto (" ncTheirBaseNonce0=" ++ show ncTheirBaseNonce0 + dmsg "updateCryptoSession else clause" + dmsg (" ncTheirBaseNonce0=" ++ show ncTheirBaseNonce0 ++ bool "(/=)" "(==)" (toMaybe ncTheirBaseNonce0 == hpTheirBaseNonce hp) ++ "hpTheirBaseNonce=" ++ show (hpTheirBaseNonce hp)) if ( ncTheirBaseNonce0 /= frmMaybe (hpTheirBaseNonce hp)) then do - dput XNetCrypto "basenonce mismatch, trigger refresh" - freshCryptoSession sessions addr hp -- basenonce mismatch, trigger refresh - else atomically $ writeTVar (ncState session) {-Accepted-}(InProgress AwaitingSessionPacket) + dmsg "basenonce mismatch, trigger refresh" + freshCryptoSession sessions addr newsession timestamp hp -- basenonce mismatch, trigger refresh + else do + writeTVar (ncState session) {-Accepted-}(InProgress AwaitingSessionPacket) + return (Nothing,return ()) anyRight :: Monad m => a -> [t] -> (t -> m (Either b b1)) -> m (Either a b1) anyRight e [] f = return $ Left e @@ -819,15 +805,25 @@ handshakeH sessions addr hshake@(Handshake (Cookie n24 ecookie) nonce24 encrypte , hpCookieRemoteDhtkey = remoteDhtPublicKey }) -> do dput XNetCrypto ("(NetCrypto)handshakeH: hpTheirBaseNonce = " ++ show theirBaseNonce) - sessionsmap <- atomically $ readTVar allsessions + -- IO action to get a new session key in case we need it in transaction to come + newsession <- generateSecretKey -- Do a lookup, so we can handle the update case differently - case Map.lookup addr sessionsmap of - Nothing -> do - dput XNetCrypto "sockaddr not in session map, so freshCryptoSession" - freshCryptoSession sessions addr hp -- create new session - Just session -> do - dput XNetCrypto "sockaddr ALREADY in session map, so updateCryptoSession" - updateCryptoSession sessions addr hp session hshake -- update existing session + let dmsg msg = trace msg (return ()) + timestamp <- getPOSIXTime + (myhandshake,launchThreads) + <- atomically $ do + sessionsmap <- readTVar allsessions + case Map.lookup addr sessionsmap of + Nothing -> do + dmsg "sockaddr not in session map, so freshCryptoSession" + freshCryptoSession sessions addr newsession timestamp hp -- create new session + Just session -> do + dmsg "sockaddr ALREADY in session map, so updateCryptoSession" + updateCryptoSession sessions addr newsession timestamp hp session hshake -- update existing session + launchThreads + forM myhandshake $ \response_handshake -> do + sendHandshake sessions addr response_handshake + return () return Nothing sessionPacketH :: NetCryptoSessions -> SockAddr -> CryptoPacket Encrypted -> IO (Maybe (x -> x)) -- cgit v1.2.3