1 files changed, 94 insertions, 26 deletions

diff --git a/ToxToXMPP.hs b/ToxToXMPP.hs
index 8d28507a..8c57da5a 100644
--- a/ToxToXMPP.hs
+++ b/ToxToXMPP.hs
@@ -1,8 +1,8 @@
-{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE CPP                      #-}
 {-# LANGUAGE LambdaCase               #-}
 {-# LANGUAGE NamedFieldPuns           #-}
 {-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE ViewPatterns             #-}
 module ToxToXMPP
     ( forkAccountWatcher
     , JabberClients
@@ -20,14 +20,15 @@ import qualified Data.Conduit.List  as CL
 import Data.XML.Types               as XML
 import EventUtil
 import Network.Tox.Crypto.Transport as Tox
+import Network.Tox.Handshake        (HandshakeParams (..))
 import Util                         (unsplitJID)
 import XMPPServer                   as XMPP
 
-import Network.Tox.DHT.Handlers (nodeSearch, nodesOfInterest)
 import Announcer
 import Announcer.Tox
 import Connection
 import Network.QueryResponse
+import Network.Tox.DHT.Handlers (nodeSearch, nodesOfInterest)
 -- import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Monad
@@ -42,6 +43,7 @@ import Network.Kademlia.Search
 import qualified Network.Tox                 as Tox
 import Network.Tox.ContactInfo               as Tox
 import qualified Network.Tox.Crypto.Handlers as Tox
+         ;import Network.Tox.Crypto.Handlers (UponCookie (..))
 -- import qualified Network.Tox.DHT.Handlers    as Tox
 import ClientState
 import Data.Bits
@@ -69,6 +71,7 @@ import GHC.Conc                  (labelThread)
 #endif
 import DPut
 import Nesting
+import qualified Network.Tox.DHT.Handlers
 
 xmppToTox :: Conduit XML.Event IO Tox.CryptoMessage
 xmppToTox = doNestingXML $ do
@@ -159,22 +162,39 @@ gotDhtPubkey pubkey tx theirKey = do
         now <- getPOSIXTime
         when (now - tm > nodeinfoStaleTime) doSearch
   where
+    tox :: Tox JabberClients
+    tox = txTox tx
+
+    myPublicKey = toPublic $ userSecret (txAccount tx)
+    me = key2id myPublicKey
+
     doSearch = do
-      let pub = toPublic $ userSecret (txAccount tx)
-          me = key2id pub
       akey <- akeyConnect (txAnnouncer tx) me theirKey
       atomically $ registerNodeCallback (toxRouting tox) (nic akey)
       scheduleSearch (txAnnouncer tx) akey meth pubkey
-    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
+
     chillSesh :: SockAddr -> STM (Maybe (Status Tox.ToxProgress))
-    chillSesh addr = traverse readTVar =<< fmap Tox.ncState . Map.lookup addr <$> readTVar byAddr
+    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
+
+    target :: NodeId
     target = key2id $ dhtpk pubkey
     meth :: SearchMethod Tox.DHTPublicKey
     meth =
@@ -193,36 +213,84 @@ 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)
 
     observe :: AnnounceKey -> POSIXTime -> NodeInfo -> STM ()
-    observe akey time (nodeAddr -> addr) = do
+    observe akey time ni@(nodeAddr -> addr) = do
       tput XNodeinfoSearch $ show ("observation", akey, time, addr)
       scheduleImmediately (txAnnouncer tx) akey $
-        ScheduledItem $ shakeHands (activeSesh addr) (getContact theirKey (txAccount tx))
+        ScheduledItem $ getCookie ni (activeSesh addr) (getContact theirKey (txAccount tx))
       setContactAddr time theirKey addr (txAccount tx)
 
-shakeHands :: STM Bool -> STM (Maybe Contact) -> Announcer -> AnnounceKey -> POSIXTime -> STM (IO ())
-shakeHands isActive getC ann akey now = do
-  mbContact <- getC
-  case mbContact of
-    Nothing -> return $ return ()
-    Just contact -> do
-      active <- isActive
-      if (not active) then do
-        scheduleRel ann akey (ScheduledItem $ shakeHands isActive getC) 5
-        return $ shakeHandsIO contact
-      else
-        return $ return ()
-
-shakeHandsIO :: Contact -> IO ()
-shakeHandsIO _ = return ()
+    getCookie
+      :: NodeInfo
+      -> STM Bool
+      -> STM (Maybe Contact)
+      -> Announcer
+      -> AnnounceKey
+      -> POSIXTime
+      -> STM (IO ())
+    getCookie ni isActive getC ann akey now = fix $ \goBack -> do
+      mbContact <- getC
+      case mbContact of
+        Nothing -> return $ return ()
+        Just contact -> do
+          active <- isActive
+          return $ when (not active) (getCookieIO goBack)
+
+      where
+
+        callRealShakeHands = realShakeHands (userSecret (txAccount tx)) theirKey (dhtpk pubkey) (toxCryptoSessions tox) (nodeAddr ni)
+
+        reschedule n f = scheduleRel ann akey f n
+        reschedule' n f = reschedule n (ScheduledItem $ \_ _ now -> f now)
+
+        cookieMaxAge = 60 * 5
+
+        getCookieIO :: STM (IO ()) -> IO ()
+        getCookieIO getCookieAgain = do
+          cookieRequest crypto client myPublicKey ni >>= \case
+            Nothing -> atomically $ reschedule' 5 (const getCookieAgain)
+            Just cookie -> do
+              void $ callRealShakeHands cookie
+              cookieCreationStamp <- getPOSIXTime
+              let shaker :: POSIXTime -> STM (IO ())
+                  shaker now = do
+                    if (now > cookieCreationStamp + cookieMaxAge)
+                      then return (getCookieIO getCookieAgain)
+                      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
+  let hp =
+        HParam
+        { hpOtherCookie = cookie
+        , hpMySecretKey = myseckey
+        , hpCookieRemotePubkey = theirpubkey
+        , hpCookieRemoteDhtkey = theirDhtKey
+        , hpTheirBaseNonce = Nothing
+        , hpTheirSessionKeyPublic = Nothing
+        }
+  newsession <- generateSecretKey
+  timestamp <- getPOSIXTime
+  (myhandshake, ioAction) <-
+    atomically $
+    Tox.freshCryptoSession allsessions saddr newsession timestamp hp
+  ioAction
+  -- send handshake
+  isJust <$> forM myhandshake (Tox.sendHandshake allsessions saddr)
 
 dispatch :: ToxToXMPP -> ContactEvent -> IO ()
-dispatch tx (SessionEstablished theirKey) = stopConnecting tx theirKey
-dispatch tx (SessionTerminated theirKey)  = startConnecting tx theirKey
+dispatch tx (SessionEstablished theirKey)                    = stopConnecting tx theirKey
+dispatch tx (SessionTerminated theirKey)                     = startConnecting tx theirKey
 dispatch tx (AddrChange   theirkey saddr)                    = return () -- todo
 dispatch tx (PolicyChange theirkey TryingToConnect         ) = startConnecting tx theirkey
 dispatch tx (PolicyChange theirkey policy                  ) = stopConnecting tx theirkey