TCP client: RoutingRequest query + cosmetic changes

4 files changed, 57 insertions, 61 deletions

diff --git a/dht/Announcer.hs b/dht/Announcer.hs
index 98fcdf94..e7c0bcd2 100644
--- a/dht/Announcer.hs
+++ b/dht/Announcer.hs
@@ -63,7 +63,7 @@ decodeAnnounceKey _ k = AnnounceKey k
 -- themselves, they are typically bootstrapped using 'scheduleImmediately' with
 -- 'NewAnnouncement' which triggers the ordinary recurring scheduling of
 -- 'Announce'.
-data ScheduledItem = ScheduledItem (Announcer -> AnnounceKey -> POSIXTime -> STM (IO ()))
+newtype ScheduledItem = ScheduledItem (Announcer -> AnnounceKey -> POSIXTime -> STM (IO ()))
  deriving Generics.Generic
 
 
diff --git a/dht/ToxManager.hs b/dht/ToxManager.hs
index 39377733..96bd9bc3 100644
--- a/dht/ToxManager.hs
+++ b/dht/ToxManager.hs
@@ -262,29 +262,10 @@ default_nospam :: Word32
 default_nospam = 0x6a7a27fc -- big-endian base64: anon/A==
 
 nodeinfoStaleTime  :: POSIXTime
-nodeinfoStaleTime = 600
+nodeinfoStaleTime = 600 -- consider DHT node address stale after 10 minutes
 
 nodeinfoSearchInterval :: POSIXTime
-nodeinfoSearchInterval = 15
-
-data Awaiting v = Since POSIXTime
-data Acquired v = At POSIXTime v
-data Moot v     = Moot
-
-data NNS a b c = NNS { -- NetcryptoNegotiationState
-  sessionDesired  :: Bool,
-  theirPublicKey  :: a Tox.DHTPublicKey,
-  theirAddress    :: b NodeInfo,
-  theirCookie     :: c (Tox.Cookie Encrypted),
-  sessionIsActive :: Bool
-}
-
-data NS
-  = Stage1 (NNS Moot Moot Moot)
-  | Stage2 (NNS Awaiting Moot Moot)
-  | Stage3 (NNS Acquired Awaiting Moot)
-  | Stage4 (NNS Acquired Acquired Awaiting)
-  | Stage5 (NNS Acquired Acquired Acquired)
+nodeinfoSearchInterval = 15 -- when no address, search DHT node every 15 seconds
 
 gotDhtPubkey :: Tox.DHTPublicKey -> ToxToXMPP -> PublicKey -> IO ()
 gotDhtPubkey theirDhtKey tx theirKey = do
@@ -303,6 +284,7 @@ gotDhtPubkey theirDhtKey tx theirKey = do
     me = key2id myPublicKey
 
     doSearch = do
+      -- TODO: attempt to connect via TCP relays.
       let akey = akeyConnect (txAnnouncer tx) me theirKey
       atomically $ registerNodeCallback (toxRouting tox) (nic akey)
       scheduleSearch (txAnnouncer tx) akey meth theirDhtKey
@@ -357,21 +339,13 @@ gotAddr' ni@(nodeAddr -> addr) tx theirKey theirDhtKey = atomically blee
 
     blee = do
       scheduleImmediately (txAnnouncer tx) akey $
-        ScheduledItem $ getCookie ni (activeSesh addr) (getContact theirKey (txAccount tx))
+        ScheduledItem $ getCookie tx theirKey theirDhtKey ni (activeSesh addr) (getContact theirKey (txAccount tx))
 
     tox :: Tox JabberClients
     tox = txTox tx
 
     crypto = toxCryptoKeys tox
 
-    {-
-    byAddr :: TVar (Map.Map SockAddr Tox.NetCryptoSession)
-    byAddr = Tox.netCryptoSessions (toxCryptoSessions tox)
-
-    readNcVar :: (Tox.NetCryptoSession -> TVar b) -> SockAddr -> STM (Maybe b)
-    readNcVar v addr = traverse readTVar =<< fmap v . Map.lookup addr <$> readTVar byAddr
-    -}
-
     activeSesh :: SockAddr -> STM Bool
     activeSesh a = do
         ss <- readTVar (txSessions tx)
@@ -390,27 +364,26 @@ gotAddr' ni@(nodeAddr -> addr) tx theirKey theirDhtKey = atomically blee
                         Just False -> return False
                         _          -> (== Established) <$> aggregateStatus c
 
-    {-
-    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
+getCookie
+      :: ToxToXMPP
+      -> PublicKey
+      -> Tox.DHTPublicKey
+      -> NodeInfo
       -> STM Bool
       -> STM (Maybe Contact)
       -> Announcer
       -> AnnounceKey
       -> POSIXTime
       -> STM (IO ())
-    getCookie ni isActive getC ann akey now = getCookieAgain
-      where
-        getCookieAgain = do
+getCookie tx theirKey theirDhtKey ni isActive getC ann akey now = getCookieAgain
+ where
+    myPublicKey = toPublic $ userSecret (txAccount tx)
+    addr = nodeAddr ni
+    hscache = toxHandshakeCache $ txTox tx
+    getCookieAgain = do
           tput XNodeinfoSearch $ show ("getCookieAgain", unpackAnnounceKey ann akey)
           mbContact  <- getC
           case mbContact of
@@ -419,23 +392,23 @@ gotAddr' ni@(nodeAddr -> addr) tx theirKey theirDhtKey = atomically blee
               active <- isActive
               return $ when (not active) getCookieIO
 
-        callRealShakeHands cookie = do
+    callRealShakeHands cookie = do
             forM_ (nodeInfo (key2id $ dhtpk theirDhtKey) (nodeAddr ni)) $ \ni' -> do
-            hs <- cacheHandshake (toxHandshakeCache tox) (userSecret (txAccount tx)) theirKey ni' cookie
+            hs <- cacheHandshake hscache (userSecret (txAccount tx)) theirKey ni' cookie
             dput XNetCrypto $  show addr ++ "<-- handshake " ++ show (key2id theirKey)
-            sendMessage (toxHandshakes tox) (nodeAddr ni) hs
+            sendMessage (toxHandshakes $ txTox tx) (nodeAddr ni) hs
 
-        reschedule n f = scheduleRel ann akey f n
-        reschedule' n f = reschedule n (ScheduledItem $ \_ _ now -> f now)
+    reschedule n f = scheduleRel ann akey f n
+    reschedule' n f = reschedule n (ScheduledItem $ \_ _ now -> f now)
 
-        cookieMaxAge = 60 * 5
+    cookieMaxAge = 60 * 5
 
-        getCookieIO :: IO ()
-        getCookieIO = do
+    getCookieIO :: IO ()
+    getCookieIO = do
           dput XNetCrypto $ show addr ++ " <-- request cookie"
-          let pending flag = setPendingCookie (toxHandshakeCache tox) myPublicKey theirKey flag
+          let pending flag = setPendingCookie hscache myPublicKey theirKey flag
           atomically $ pending True
-          cookieRequest crypto client myPublicKey ni >>= \case
+          cookieRequest (toxCryptoKeys $ txTox tx) (toxDHT $ txTox tx) myPublicKey ni >>= \case
             Nothing -> atomically $ do
                         pending False
                         reschedule' 5 (const getCookieAgain)
@@ -485,10 +458,10 @@ realShakeHands myseckey theirpubkey theirDhtKey allsessions saddr cookie = do
 
 
 dispatch :: ToxToXMPP -> ContactEvent -> IO ()
-dispatch tx (SessionEstablished theirKey)                    = do stopConnecting tx theirKey "established"
+dispatch tx (SessionEstablished theirKey                   ) = do stopConnecting tx theirKey "established"
                                                                   updateRoster tx theirKey
-dispatch tx (SessionTerminated theirKey)                     = startConnecting tx theirKey "terminated"
-dispatch tx (AddrChange   theirKey saddr)                    = gotAddr saddr tx theirKey
+dispatch tx (SessionTerminated theirKey                    ) = startConnecting tx theirKey "terminated"
+dispatch tx (AddrChange   theirKey saddr                   ) = gotAddr saddr tx theirKey
 dispatch tx (PolicyChange theirkey TryingToConnect         ) = startConnecting tx theirkey "policy"
 dispatch tx (PolicyChange theirkey policy                  ) = stopConnecting tx theirkey "policy"
 dispatch tx (OnionRouted  theirKey (OnionDHTPublicKey pkey)) = gotDhtPubkey pkey tx theirKey
diff --git a/dht/src/Data/Tox/Relay.hs b/dht/src/Data/Tox/Relay.hs
index 64c90806..1bce76db 100644
--- a/dht/src/Data/Tox/Relay.hs
+++ b/dht/src/Data/Tox/Relay.hs
@@ -72,8 +72,9 @@ data RelayPacket
 newtype PacketNumber = PacketNumber { packetNumberToWord8 :: Word8 }
  deriving (Eq,Ord,Show)
 
-pattern PingPacket    = PacketNumber 4
-pattern OnionPacketID = PacketNumber 8
+pattern RoutingRequestPacket  = PacketNumber 0
+pattern PingPacket            = PacketNumber 4
+pattern OnionPacketID         = PacketNumber 8
 
 packetNumber :: RelayPacket -> PacketNumber
 packetNumber (RelayData _ (ConId conid)) = PacketNumber $ conid -- 0 to 15 not allowed.
diff --git a/dht/src/Network/Tox/TCP.hs b/dht/src/Network/Tox/TCP.hs
index 1531dfb4..4b3a4594 100644
--- a/dht/src/Network/Tox/TCP.hs
+++ b/dht/src/Network/Tox/TCP.hs
@@ -16,6 +16,7 @@ import Control.Monad
 import Crypto.Random
 import Data.Aeson (ToJSON(..),FromJSON(..))
 import qualified Data.Aeson as JSON
+import Data.ByteArray (withByteArray)
 import Data.Functor.Contravariant
 import Data.Functor.Identity
 import Data.Hashable
@@ -26,9 +27,11 @@ import Data.Monoid
 import Data.Serialize
 import Data.Word
 import qualified Data.Vector as Vector
+import Foreign.Storable (peek)
 import Network.Socket (SockAddr(..))
 import qualified Text.ParserCombinators.ReadP as RP
 import System.IO.Error
+import System.IO.Unsafe (unsafeDupablePerformIO)
 import System.Timeout
 
 import ControlMaybe
@@ -270,8 +273,25 @@ tcpPing client dst = do
                 , method         = PingPacket
                 }
 
+tcpConnectionRequest :: Client err PacketNumber tid addr (Bool, RelayPacket)
+                        -> PublicKey -> addr -> IO (Maybe ConId)
+tcpConnectionRequest client pubkey ni = do
+    sendQuery client meth pubkey ni
+ where
+    meth = MethodSerializer
+        { wrapQuery      = \n8 src dst pubkey -> (True,RoutingRequest pubkey)
+        , unwrapResponse = \(_,RoutingResponse cid pubkey) -> cid
+        , methodTimeout  = \dst -> return (dst,5000000)
+        , method         = RoutingRequestPacket
+        }
+
 type RelayClient = Client String PacketNumber Nonce8 NodeInfo (Bool,RelayPacket)
 
+keyToNonce :: PublicKey -> Nonce8
+keyToNonce k = unsafeDupablePerformIO $ withByteArray k $ \ptr -> do
+    w8 <- peek ptr
+    return $ Nonce8 w8
+
 -- | Create a new TCP relay client.  Because polymorphic existential record
 -- updates are currently hard with GHC, this function accepts parameters for
 -- generalizing the table-entry type for pending transactions.  Safe trivial
@@ -291,11 +311,13 @@ newClient crypto store load = do
         { clientNet = {- XXX: Client type forces this pointless layering. -} layerTransport ((Right .) . (,) . (,) False) (,) net
         , clientDispatcher = DispatchMethods
             { classifyInbound = (. snd) $ \case
-                RelayPing n           -> IsQuery PingPacket n
-                RelayPong n           -> IsResponse n
+                RelayPing n             -> IsQuery PingPacket n
+                RelayPong n             -> IsResponse n
+                RoutingRequest k        -> IsQuery RoutingRequestPacket (keyToNonce k)
+                RoutingResponse conId k -> IsResponse (keyToNonce k)
                 OnionPacketResponse (OnionAnnounceResponse n8 n24 ciphered) -> IsResponse n8
                 OnionPacketResponse o@(OnionToRouteResponse _) -> IsUnsolicited $ handle2route o
-                OOBRecv k bs          -> IsUnsolicited $ handleOOB k bs
+                OOBRecv k bs            -> IsUnsolicited $ handleOOB k bs
                 wut                   -> IsUnknown (show wut)
             , lookupHandler   = \case
                 PingPacket -> trace ("tcp-received-ping") $ Just MethodHandler