more careful updateCryptoSession

1 files changed, 34 insertions, 10 deletions

diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs
index b7414095..6f20e670 100644
--- a/src/Network/Tox/Crypto/Handlers.hs
+++ b/src/Network/Tox/Crypto/Handlers.hs
@@ -268,12 +268,13 @@ data NetCryptoSession = NCrypto
     -- is started, its ThreadId is stored here
     , ncPingMachine        :: Maybe PingMachine
     -- ^ when the ping thread is started, store it here
-    , ncOutgoingQueue      :: UponHandshake
-                                (PQ.PacketOutQueue
-                                      (State,Nonce24,RangeMap TArray Word8 TVar)
-                                      CryptoMessage
-                                      (CryptoPacket Encrypted)
-                                      CryptoData)
+    , ncOutgoingQueue      :: TVar
+                                (UponHandshake
+                                    (PQ.PacketOutQueue
+                                          (State,Nonce24,RangeMap TArray Word8 TVar)
+                                          CryptoMessage
+                                          (CryptoPacket Encrypted)
+                                          CryptoData))
     -- ^ To send a message add it to this queue, by calling 'tryAppendQueueOutgoing'
     --   but remember to call 'readyOutGoing' first, because the shared secret cache
     --   presently requires the IO monad.
@@ -546,6 +547,7 @@ freshCryptoSession  sessions
      <- case mbtheirSessionKey of
          Nothing -> return NeedHandshake
          Just theirSessionKey -> createNetCryptoOutQueue sessions newsession theirSessionKey pktq ncMyPacketNonce0 ncOutgoingIdMap0
+    mbpktoqVar <- newTVar mbpktoq
     lastNQ <- CB.new 10 0 :: STM (CyclicBuffer (Bool,(ViewSnapshot,InOrOut CryptoMessage)))
     listeners <- newTVar IntMap.empty
     msgNum <- newTVar 0
@@ -578,7 +580,7 @@ freshCryptoSession  sessions
                     , ncPacketQueue        = pktq
                     , ncDequeueThread      = Nothing -- error "you want the NetCrypto-Dequeue thread id, but is it started?"
                     , ncPingMachine        = Nothing -- error "you want the NetCrypto-PingMachine, but is it started?"
-                    , ncOutgoingQueue      = mbpktoq
+                    , ncOutgoingQueue      = mbpktoqVar
                     , ncLastNMsgs          = lastNQ
                     , ncListeners          = listeners
                     }
@@ -726,8 +728,30 @@ updateCryptoSession sessions addr newsession timestamp hp session handshake = do
                          ++ "hpTheirBaseNonce=" ++ show (hpTheirBaseNonce hp))
           if ( ncTheirBaseNonce0 /= frmMaybe (hpTheirBaseNonce hp))
             then do
-                dmsg "basenonce mismatch, trigger refresh"
-                freshCryptoSession sessions addr newsession timestamp hp -- basenonce mismatch, trigger refresh
+                case ncTheirBaseNonce0 of
+                    NeedHandshake | Just theirSessionPublic <- hpTheirSessionKeyPublic hp -> do
+                        writeTVar (ncTheirBaseNonce session) (frmMaybe (hpTheirBaseNonce hp))
+                        writeTVar (ncTheirBaseNonce session) (frmMaybe (hpTheirBaseNonce hp))
+                        writeTVar (ncTheirSessionPublic session) (frmMaybe (hpTheirSessionKeyPublic hp))
+                        writeTVar (ncHandShake session) (HaveHandshake handshake)
+                        writeTVar (ncState session) {-Accepted-}(InProgress AwaitingSessionPacket)
+                        mbpktoq <- createNetCryptoOutQueue
+                                                sessions
+                                                newsession
+                                                theirSessionPublic
+                                                (ncPacketQueue session)
+                                                (ncMyPacketNonce session)
+                                                (ncOutgoingIdMap session)
+                        writeTVar (ncOutgoingQueue session) mbpktoq
+                        return (Nothing,maybe (dput XNetCrypto "ERROR: something went wrong creating the ncOutgoingQueue")
+                                              (runUponHandshake session addr)
+                                              (toMaybe mbpktoq))
+                    HaveHandshake _ -> do
+                        dmsg "basenonce mismatch, trigger refresh"
+                        freshCryptoSession sessions addr newsession timestamp hp -- basenonce mismatch, trigger refresh
+                    _ -> do
+                        dmsg "updateCryptoSession -- unexpected condition! have hpTheirSessionKeyPublic but missing hpTheirBaseNonce?"
+                        return (Nothing,return ())
             else do
                 writeTVar (ncState session) {-Accepted-}(InProgress AwaitingSessionPacket)
                 return (Nothing,return ())
@@ -1000,7 +1024,7 @@ allMsgTypes fDefault = A.listArray (minBound,maxBound) (0:knownMsgs)
 
 sendCrypto :: TransportCrypto -> NetCryptoSession -> (STM ()) -> CryptoMessage -> IO (Either String ())
 sendCrypto crypto session updateLocal cm = do
-    let HaveHandshake outq = ncOutgoingQueue session
+    HaveHandshake outq <- atomically $ readTVar (ncOutgoingQueue session)
     -- XXX: potential race? if shared secret comes out of sync with cache?
     dput XNetCrypto "sendCrypto: enter "
     getOutGoingParam <- PQ.readyOutGoing outq