6 files changed, 143 insertions, 40 deletions

diff --git a/src/Data/Tox/Relay.hs b/src/Data/Tox/Relay.hs
index 1437c9cd..1fe6d256 100644
--- a/src/Data/Tox/Relay.hs
+++ b/src/Data/Tox/Relay.hs
@@ -45,8 +45,8 @@ data RelayPacket
     | RelayPong Nonce8
     | OOBSend PublicKey ByteString
     | OOBRecv PublicKey ByteString
-    | OnionPacket (OnionRequest N0)
-    | OnionPacketResponse (OnionResponse N1)
+    | OnionPacket Nonce24 (Addressed (Forwarding N2 (OnionMessage Encrypted))) -- (OnionRequest N0)
+    | OnionPacketResponse (OnionMessage Encrypted)
     -- 0x0A through 0x0F reserved for future use.
     | RelayData ByteString ConId
  deriving (Eq,Ord,Show,Data)
@@ -65,9 +65,9 @@ instance Sized RelayPacket where
         RelayPong pingid             -> 8
         OOBSend k bs                 -> 32 + B.length bs
         OOBRecv k bs                 -> 32 + B.length bs
-        OnionPacket query            -> case contramap (`asTypeOf` query) size of
-                                            ConstSize n -> n
-                                            VarSize f   -> f query
+        OnionPacket n24 query        -> 24 + case contramap (`asTypeOf` query) size of
+                                                ConstSize n -> n
+                                                VarSize f   -> f query
         OnionPacketResponse answer   -> case contramap (`asTypeOf` answer) size of
                                             ConstSize n -> n
                                             VarSize f   -> f answer
@@ -86,7 +86,7 @@ instance Serialize RelayPacket where
             5 -> RelayPong <$> get
             6 -> OOBSend <$> getPublicKey <*> (remaining >>= getBytes)
             7 -> OOBRecv <$> getPublicKey <*> (remaining >>= getBytes)
-            8 -> OnionPacket <$> get
+            8 -> OnionPacket <$> get <*> get
             9 -> OnionPacketResponse <$> get
             conid -> (`RelayData` ConId conid) <$> (remaining >>= getBytes)
 
@@ -101,7 +101,7 @@ instance Serialize RelayPacket where
             RelayPong pingid             -> put pingid
             OOBSend k bs                 -> putPublicKey k >> putByteString bs
             OOBRecv k bs                 -> putPublicKey k >> putByteString bs
-            OnionPacket query            -> put query
+            OnionPacket n24 query        -> put n24 >> put query
             OnionPacketResponse answer   -> put answer
             RelayData bs _               -> putByteString bs
 
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index 83a17037..46d87094 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -240,7 +240,7 @@ newTox :: TVar Onion.AnnouncedKeys   -- ^ Store of announced keys we are a rende
        -> [String]                   -- ^ Bind-address to listen on. Must provide at least one.
        -> ( ContactInfo extra -> SockAddr -> Session -> IO () )
        -> Maybe SecretKey            -- ^ Optional DHT secret key to use.
-        -> ( Int -> Onion.OnionResponse Onion.N1 -> IO () ) -- ^ TCP-bound onion responses.
+        -> ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses.
        -> IO (Tox extra)
 newTox keydb bindspecs onsess suppliedDHTKey tcp = do
     addrs <- mapM (`getBindAddress` True) bindspecs
@@ -262,7 +262,7 @@ newToxOverTransport :: TVar Onion.AnnouncedKeys
         -> ( ContactInfo extra -> SockAddr -> Session -> IO () )
         -> Maybe SecretKey
         -> Onion.UDPTransport
-        -> ( Int -> Onion.OnionResponse Onion.N1 -> IO () ) -- ^ TCP-bound onion responses.
+        -> ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses.
         -> IO (Tox extra)
 newToxOverTransport keydb addr onNewSession suppliedDHTKey udp tcp = do
     roster <- newContactInfo
diff --git a/src/Network/Tox/Onion/Transport.hs b/src/Network/Tox/Onion/Transport.hs
index 0cb03718..8918f913 100644
--- a/src/Network/Tox/Onion/Transport.hs
+++ b/src/Network/Tox/Onion/Transport.hs
@@ -44,14 +44,18 @@ module Network.Tox.Onion.Transport
     , OnionRoute(..)
     , N0
     , N1
+    , N2
     , N3
     , onionKey
     , onionAliasSelector
     , selectAlias
     , RouteId(..)
     , routeId
-    , rewrap
     , putRequest
+    , wrapForRoute
+    , wrapSymmetric
+    , wrapOnion
+    , wrapOnionPure
     ) where
 
 import Network.Address (fromSockAddr,toSockAddr,setPort,either4or6,sockAddrPort)
@@ -91,6 +95,7 @@ import DPut
 import DebugTag
 import Data.Word64Map (fitsInInt)
 import Data.Bits (shiftR,shiftL)
+import qualified Rank2
 
 type HandleLo a = Maybe (Either String (ByteString, SockAddr)) -> IO a
 
@@ -124,6 +129,26 @@ deriving instance ( Show (f (AnnounceRequest, Nonce8))
                   , Show (f DataToRoute)
                   ) => Show (OnionMessage f)
 
+instance Data (OnionMessage Encrypted) where
+  gfoldl f z txt = z (either error id . S.decode) `f` S.encode txt
+  toConstr _     = error "OnionMessage.toConstr"
+  gunfold _ _    = error "OnionMessage.gunfold"
+#if MIN_VERSION_base(4,2,0)
+  dataTypeOf _   = mkNoRepType "Network.Tox.Onion.Transport.OnionMessage"
+#else
+  dataTypeOf _   = mkNorepType "Network.Tox.Onion.Transport.OnionMessage"
+#endif
+
+instance Rank2.Functor OnionMessage where
+    f <$> m = mapPayload (Proxy :: Proxy Serialize) f m
+
+instance Payload Serialize OnionMessage where
+    mapPayload _ f (OnionAnnounce a)                = OnionAnnounce (fmap f a)
+    mapPayload _ f (OnionAnnounceResponse n8 n24 a) = OnionAnnounceResponse n8 n24 (f a)
+    mapPayload _ f (OnionToRoute k a)               = OnionToRoute k a
+    mapPayload _ f (OnionToRouteResponse a)         = OnionToRouteResponse a
+
+
 msgNonce :: OnionMessage f -> Nonce24
 msgNonce (OnionAnnounce a)               = asymmNonce a
 msgNonce (OnionAnnounceResponse _ n24 _) = n24
@@ -274,10 +299,10 @@ encodeOnionAddr crypto getRoute (msg,OnionDestination _ ni (Just rid)) = do
     return x
 
 
-forwardOnions :: TransportCrypto -> UDPTransport -> (Int -> OnionResponse N1 -> IO ()) {- ^ TCP relay send -} -> UDPTransport
+forwardOnions :: TransportCrypto -> UDPTransport -> (Int -> OnionMessage Encrypted -> IO ()) {- ^ TCP relay send -} -> UDPTransport
 forwardOnions crypto udp sendTCP = udp { awaitMessage = forwardAwait crypto udp sendTCP }
 
-forwardAwait :: TransportCrypto -> UDPTransport -> (Int -> OnionResponse N1 -> IO ()) {- ^ TCP relay send -} -> HandleLo a -> IO a
+forwardAwait :: TransportCrypto -> UDPTransport -> (Int -> OnionMessage Encrypted -> IO ()) {- ^ TCP relay send -} -> HandleLo a -> IO a
 forwardAwait crypto udp sendTCP kont = do
     fix $ \another -> do
       awaitMessage udp $ \case
@@ -325,6 +350,7 @@ data OnionRequest n = OnionRequest
  deriving (Eq,Ord)
 
 
+{-
 instance (Typeable n, Sized (ReturnPath n), Serialize (ReturnPath n)
          , Serialize (Forwarding (ThreeMinus n) (OnionMessage Encrypted))
          ) => Data (OnionRequest n) where
@@ -336,6 +362,8 @@ instance (Typeable n, Sized (ReturnPath n), Serialize (ReturnPath n)
 #else
   dataTypeOf _   = mkNorepType "Network.Tox.Onion.Transport.OnionRequest"
 #endif
+-}
+
 
 instance (Typeable n, Serialize (ReturnPath n)) => Data (OnionResponse n) where
   gfoldl f z txt = z (either error id . S.decode) `f` S.encode txt
@@ -397,7 +425,17 @@ instance (Sized (ReturnPath n)) => Sized (OnionResponse (S n)) where
 
 data Addressed a = Addressed { sockAddr :: SockAddr, unaddressed :: a }
                  | TCPIndex { tcpIndex :: Int, unaddressed :: a }
- deriving (Eq,Show)
+ deriving (Eq,Ord,Show)
+
+instance (Typeable a, Serialize a) => Data (Addressed a) where
+  gfoldl f z a   = z (either error id . S.decode) `f` S.encode a
+  toConstr _     = error "Addressed.toConstr"
+  gunfold _ _    = error "Addressed.gunfold"
+#if MIN_VERSION_base(4,2,0)
+  dataTypeOf _   = mkNoRepType "Network.Tox.Onion.Transport.Addressed"
+#else
+  dataTypeOf _   = mkNorepType "Network.Tox.Onion.Transport.Addressed"
+#endif
 
 instance Sized a => Sized (Addressed a) where
     size = case size :: Size a of
@@ -434,6 +472,10 @@ addrToIndex _ = 0
 indexToAddr :: Int -> SockAddr
 indexToAddr x = SockAddrInet6 0 0 (fromIntegral x, fromIntegral (x `shiftR` 32),0,0) 0
 
+-- Note, toxcore would check an address family byte here to detect a TCP-bound
+-- packet, but we instead use the IPv6 id and rely on the port number being
+-- zero.  Since it will be symmetrically encrypted for our eyes only, it's not
+-- important to conform on this point.
 instance Serialize a => Serialize (Addressed a) where
     get = do saddr <- getForwardAddr
              a <- get
@@ -549,6 +591,7 @@ instance (Serialize (Encrypted (Addressed (Forwarding n msg)))) => Serialize (Fo
     get = Forwarding <$> getPublicKey <*> get
     put (Forwarding k x) = putPublicKey k >> put x
 
+{-
 rewrap :: (ThreeMinus n ~ S (ThreeMinus (S n)),
                  Serialize (ReturnPath n),
                  Serialize
@@ -565,6 +608,7 @@ rewrap crypto saddr (OnionRequest nonce msg rpath) = do
         Addressed dst msg'
           -> Right (OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath, dst)
         _ -> Left "Onion forward to TCP client?"
+-}
 
 handleOnionRequest :: forall a proxy n.
                       ( LessThanThree n
@@ -584,7 +628,6 @@ handleOnionRequest proxy crypto saddr udp kont (OnionRequest nonce msg rpath) =
 
     case peeled of
         Left e -> do
-            -- todo report encryption error
             dput XOnion $ unwords [ "peelOnion:", show n, showDestination, e]
             kont
         Right (Addressed dst msg') -> do
@@ -617,7 +660,7 @@ handleOnionResponse :: (KnownPeanoNat n, Sized (ReturnPath n), Serialize (Return
                         -> TransportCrypto
                         -> SockAddr
                         -> UDPTransport
-                        -> (Int -> OnionResponse N1 -> IO ()) -- ^ TCP-relay onion send.
+                        -> (Int -> OnionMessage Encrypted -> IO ()) -- ^ TCP-relay onion send.
                         -> IO a
                         -> OnionResponse (S n)
                         -> IO a
@@ -633,10 +676,9 @@ handleOnionResponse proxy crypto saddr udp sendTCP kont (OnionResponse path msg)
             sendMessage udp dst (runPut $ putResponse $ OnionResponse path' msg)
             kont
         Right (TCPIndex dst path') -> do
-            -- This should only occur for OnionResponse N1
-            case gcast (OnionResponse path' msg) of
-                Just supported -> sendTCP dst supported
-                Nothing        -> dput XUnexpected "handleOnionResponse: TCP-bound message not supported."
+            case peanoVal path' of
+                0 -> sendTCP dst msg
+                n -> dput XUnexpected $ "handleOnionResponse: TCP-bound OnionResponse" ++ show n ++ " not supported."
             kont
 
 
@@ -900,6 +942,17 @@ wrapOnion crypto skey nonce destkey saddr fwd = do
     secret <- lookupSharedSecret crypto skey destkey nonce
     return $ Forwarding (toPublic skey) $ ToxCrypto.encrypt secret plain
 
+wrapOnionPure :: Serialize (Forwarding n msg) =>
+           SecretKey
+           -> ToxCrypto.State
+           -> SockAddr
+           -> Forwarding n msg
+           -> Forwarding (S n) msg
+wrapOnionPure skey st saddr fwd = Forwarding (toPublic skey) (ToxCrypto.encrypt st plain)
+ where
+    plain = encodePlain $ Addressed saddr fwd
+
+
 
 -- TODO
 -- Two types of packets may be sent to Rendezvous via OnionToRoute requests.
diff --git a/src/Network/Tox/Relay.hs b/src/Network/Tox/Relay.hs
index 7af14ed6..2842fcc2 100644
--- a/src/Network/Tox/Relay.hs
+++ b/src/Network/Tox/Relay.hs
@@ -201,22 +201,23 @@ handlePacket cons thistcp me crypto sendOnion sendToMe session = \case
             sendToThem' <- IntMap.lookup i $ associated mySession
             return $ sendToThem' $ RelayData bs
 
-    OnionPacket p -> do
-        mp <- rewrap crypto (TCPIndex thistcp) p
-        case mp of
-            Right (p',addr) -> sendOnion addr p'
-            _               -> return ()
+    OnionPacket n24 (Addressed addr req) -> do
+        rpath <- atomically $ do
+                    sym <- transportSymmetric crypto
+                    n <- transportNewNonce crypto
+                    return $ wrapSymmetric sym n (TCPIndex thistcp) NoReturnPath
+        sendOnion addr $ OnionRequest n24 req rpath
 
     _ -> return ()
 
 
-sendTCP_ :: TVar (IntMap (RelayPacket -> IO ())) -> Int -> OnionResponse N1 -> IO ()
+sendTCP_ :: TVar (IntMap (RelayPacket -> IO ())) -> Int -> OnionMessage Encrypted -> IO ()
 sendTCP_ st addr x = join $ atomically
     $ IntMap.lookup addr <$> readTVar st >>= \case
         Nothing   -> return $ return ()
         Just send -> return $ send $ OnionPacketResponse x
 
-tcpRelay :: SockAddr -> (SockAddr -> OnionRequest N1 -> IO ()) -> IO (ServerHandle, Int -> OnionResponse N1 -> IO ())
+tcpRelay :: SockAddr -> (SockAddr -> OnionRequest N1 -> IO ()) -> IO (ServerHandle, Int -> OnionMessage Encrypted -> IO ())
 tcpRelay udp_addr sendOnion = do
     crypto <- newCrypto
     cons <- newTVarIO Map.empty
diff --git a/src/Network/Tox/TCP.hs b/src/Network/Tox/TCP.hs
index 608becc3..c9c3d9a6 100644
--- a/src/Network/Tox/TCP.hs
+++ b/src/Network/Tox/TCP.hs
@@ -7,6 +7,7 @@ module Network.Tox.TCP where
 import Control.Arrow
 import Control.Concurrent
 import Control.Concurrent.STM
+import Control.Monad
 import Crypto.Random
 import Data.Functor.Contravariant
 import Data.Functor.Identity
@@ -22,11 +23,12 @@ import DebugTag
 import DPut
 import Network.Address (setPort,PortNumber)
 import Network.Kademlia.Routing
-import Network.Kademlia.Search
+import Network.Kademlia.Search hiding (sendQuery)
 import Network.QueryResponse
 import Network.QueryResponse.TCP
 import Network.Tox.DHT.Handlers (toxSpace)
-import Network.Tox.Onion.Transport (OnionMessage(..),OnionResponse(..),N1)
+import Network.Tox.Onion.Transport hiding (encrypt,decrypt)
+import Network.Tox.Onion.Handlers (unwrapAnnounceResponse)
 import qualified Network.Tox.NodeId as UDP
 
 
@@ -103,30 +105,77 @@ toxTCP crypto = tcpTransport 30 (tcpStream crypto)
 tcpSpace :: KademliaSpace NodeId NodeInfo
 tcpSpace = contramap udpNodeInfo toxSpace
 
-nodeSearch :: Client err meth tid NodeInfo RelayPacket -> Search NodeId (IP, PortNumber) () NodeInfo NodeInfo
-nodeSearch client = Search
+nodeSearch :: TCPClient err () Nonce8 -> Search NodeId (IP, PortNumber) () NodeInfo NodeInfo
+nodeSearch tcp = Search
     { searchSpace       = tcpSpace
     , searchNodeAddress = nodeIP &&& tcpPort
-    , searchQuery       = getNodes client
+    , searchQuery       = getTCPNodes tcp
     }
 
-getNodes :: Client err meth tid NodeInfo RelayPacket -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo], [NodeInfo], Maybe ()))
-getNodes client seeking dst = do
-    return Nothing -- TODO
+data TCPClient err meth tid = TCPClient
+    { tcpCrypto     :: TransportCrypto
+    , tcpClient     :: Client err () tid NodeInfo RelayPacket
+    , tcpGetGateway :: UDP.NodeInfo -> STM (Maybe NodeInfo)
+    }
+
+getTCPNodes :: TCPClient err () Nonce8 -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ()))
+getTCPNodes tcp seeking dst = do
+    r <- getUDPNodes tcp seeking (udpNodeInfo dst)
+    let tcps (ns,_,mb) = (ns',ns',mb)
+         where ns' = do
+                    n <- ns
+                    [ NodeInfo n (fromIntegral 443) , NodeInfo n (fromIntegral 80) , NodeInfo n (UDP.nodePort n) ]
+    return $ tcps <$> r
+
+getUDPNodes :: TCPClient err () Nonce8 -> NodeId -> UDP.NodeInfo -> IO (Maybe ([UDP.NodeInfo], [UDP.NodeInfo], Maybe ()))
+getUDPNodes tcp seeking dst = do
+    mgateway <- atomically $ tcpGetGateway tcp dst
+    fmap join $ forM mgateway $ \gateway -> do
+        (b,c,n24) <- atomically $ do
+            b <- transportNewKey (tcpCrypto tcp)
+            c <- transportNewKey (tcpCrypto tcp)
+            n24 <- transportNewNonce (tcpCrypto tcp)
+            return (b,c,n24)
+        wrap2 <- lookupNonceFunction (tcpCrypto tcp) b (UDP.id2key $ UDP.nodeId dst)
+        wrap1 <- lookupNonceFunction (tcpCrypto tcp) c (UDP.id2key $ nodeId gateway)
+        wrap0 <- lookupNonceFunction (tcpCrypto tcp) (transportSecret $ tcpCrypto tcp) (UDP.id2key $ UDP.nodeId dst)
+        let meth = MethodSerializer -- MethodSerializer Nonce8 NodeInfo RelayPacket meth AnnounceRequest (Either String AnnounceResponse)
+                    { methodTimeout = \tid addr -> return (addr,8000000) -- 8 second timeout
+                    , method = () -- meth
+                    , wrapQuery = \n8 src dst x ->
+                        OnionPacket n24 $ Addressed (UDP.nodeAddr $ udpNodeInfo dst)
+                            $ wrapOnionPure b (wrap2 n24) (UDP.nodeAddr $ udpNodeInfo dst)
+                                $ wrapOnionPure c (wrap1 n24) (nodeAddr gateway)
+                                    $ NotForwarded $ encryptPayload (wrap0 n24)
+                                       $ OnionAnnounce Asymm
+                                            { senderKey  = transportPublic (tcpCrypto tcp)
+                                            , asymmNonce = n24
+                                            , asymmData  = pure (x,n8)
+                                            }
+                    , unwrapResponse = \case
+                        OnionPacketResponse (OnionAnnounceResponse _ n24' r)
+                            -> decrypt (wrap0 n24') r >>= decodePlain
+                        x   -> Left $ "getUDPNodes: unwrapResponse fail " ++ show x
+                    }
+        r <- sendQuery (tcpClient tcp) meth (AnnounceRequest zeros32 seeking UDP.zeroID) gateway
+        forM r $ \response -> do
+            let (ns,_,mb) = either (const ([],[],Nothing)) (unwrapAnnounceResponse Nothing dst) $ response
+            return (ns,ns, const () <$> mb)
+
 
 handleOOB :: PublicKey -> ByteString -> NodeInfo -> NodeInfo -> IO (Maybe (RelayPacket -> RelayPacket))
 handleOOB k bs src dst = do
     dput XMisc $ "TODO: handleOOB " ++ show src
     return Nothing
 
-handle2route :: OnionResponse N1 -> NodeInfo -> NodeInfo -> IO (Maybe (RelayPacket -> RelayPacket))
+handle2route :: OnionMessage Encrypted -> NodeInfo -> NodeInfo -> IO (Maybe (RelayPacket -> RelayPacket))
 handle2route o src dst = do
     dput XMisc $ "TODO: handle2route " ++ show src
     return Nothing
 
 
-tcpClient :: TransportCrypto -> IO (Client String () Nonce8 NodeInfo RelayPacket)
-tcpClient crypto = do
+newClient :: TransportCrypto -> IO (Client String () Nonce8 NodeInfo RelayPacket)
+newClient crypto = do
     net <- toxTCP crypto
     drg <- drgNew
     map_var <- atomically $ newTVar (drg, Data.Word64Map.empty)
@@ -136,8 +185,8 @@ tcpClient crypto = do
             { classifyInbound = \case
                 RelayPing n           -> IsQuery () n
                 RelayPong n           -> IsResponse n
-                OnionPacketResponse (OnionResponse _ (OnionAnnounceResponse n8 n24 ciphered)) -> IsResponse n8
-                OnionPacketResponse o@(OnionResponse _ (OnionToRouteResponse _)) -> IsUnsolicited $ handle2route o
+                OnionPacketResponse (OnionAnnounceResponse n8 n24 ciphered) -> IsResponse n8
+                OnionPacketResponse o@(OnionToRouteResponse _) -> IsUnsolicited $ handle2route o
                 OOBRecv k bs          -> IsUnsolicited $ handleOOB k bs
             , lookupHandler   = \() -> Just MethodHandler
                     { methodParse     = \(RelayPing n8) -> Right ()
diff --git a/src/Network/Tox/Transport.hs b/src/Network/Tox/Transport.hs
index 0b34e8f8..e79e4d8b 100644
--- a/src/Network/Tox/Transport.hs
+++ b/src/Network/Tox/Transport.hs
@@ -22,7 +22,7 @@ toxTransport ::
           -> OnionRouter
           -> (PublicKey -> IO (Maybe NodeInfo))
           -> UDPTransport
-          -> (Int -> OnionResponse N1 -> IO ()) -- ^ TCP-bound callback.
+          -> (Int -> OnionMessage Encrypted -> IO ()) -- ^ TCP-bound callback.
           -> IO ( Transport String SockAddr (CryptoPacket Encrypted)
                 , Transport String NodeInfo (DHTMessage Encrypted8)
                 , Transport String (OnionDestination RouteId) (OnionMessage Encrypted)