From 8df4213da5b8ff9faff6194a06bd2c9c00dbad16 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Fri, 10 Jan 2020 02:51:51 -0500 Subject: First successful TCP relay mediated chat link! --- dht/src/Data/Tox/DHT/Multi.hs | 39 ++++++-- dht/src/Data/Tox/Onion.hs | 35 +++++--- dht/src/Network/Tox.hs | 12 ++- dht/src/Network/Tox/DHT/Transport.hs | 17 ++-- dht/src/Network/Tox/NodeId.hs | 167 ----------------------------------- dht/src/Network/Tox/TCP.hs | 3 +- dht/src/Network/Tox/Transport.hs | 8 +- 7 files changed, 81 insertions(+), 200 deletions(-) diff --git a/dht/src/Data/Tox/DHT/Multi.hs b/dht/src/Data/Tox/DHT/Multi.hs index 7c8804b5..8d614262 100644 --- a/dht/src/Data/Tox/DHT/Multi.hs +++ b/dht/src/Data/Tox/DHT/Multi.hs @@ -11,7 +11,7 @@ import Crypto.PubKey.Curve25519 (PublicKey) import qualified Network.Tox.NodeId as UDP ;import Network.Tox.NodeId (NodeId) import qualified Network.Tox.TCP.NodeId as TCP -import Data.Tox.Onion (OnionDestination,RouteId) +import Data.Tox.Onion (OnionDestination,RouteId,AnnouncedRendezvous) import Data.Tox.Relay hiding (NodeInfo) import Network.Address (either4or6) import Network.Tox.TCP as TCP (ViaRelay(..), tcpConnectionRequest_) @@ -45,8 +45,8 @@ instance GCompare T where gcompare TCP TCP = GEQ gcompare TCP UDP = GGT instance GShow T where - gshowsPrec _ UDP = showString "UDP" - gshowsPrec _ TCP = showString "TCP" + gshowsPrec _ UDP = showString "UDP" + gshowsPrec _ TCP = showString "TCP" data S addr where SessionUDP :: S SockAddr @@ -62,8 +62,8 @@ instance GCompare S where gcompare SessionTCP SessionTCP = GEQ gcompare SessionTCP SessionUDP = GGT instance GShow S where - gshowsPrec _ SessionUDP = showString "UDP" - gshowsPrec _ SessionTCP = showString "TCP" + gshowsPrec _ SessionUDP = showString "UDP" + gshowsPrec _ SessionTCP = showString "TCP" data O addr where OnionUDP :: O (OnionDestination RouteId) @@ -79,8 +79,8 @@ instance GCompare O where gcompare OnionTCP OnionTCP = GEQ gcompare OnionTCP OnionUDP = GGT instance GShow O where - gshowsPrec _ OnionUDP = showString "UDP" - gshowsPrec _ OnionTCP = showString "TCP" + gshowsPrec _ OnionUDP = showString "UDP" + gshowsPrec _ OnionTCP = showString "TCP" untagOnion :: DSum O Identity -> OnionDestination RouteId untagOnion (OnionUDP :=> Identity o) = o @@ -95,10 +95,28 @@ type NodeInfo = DSum T Identity type SessionAddress = DSum S Identity type OnionAddress = DSum O Identity +data R addr where + RendezvousUDP :: R AnnouncedRendezvous + RendezvousTCP :: R AnnouncedRendezvous + +instance GEq R where + geq RendezvousUDP RendezvousUDP = Just Refl + geq RendezvousTCP RendezvousTCP = Just Refl + geq _ _ = Nothing +instance GCompare R where + gcompare RendezvousUDP RendezvousUDP = GEQ + gcompare RendezvousUDP RendezvousTCP = GLT + gcompare RendezvousTCP RendezvousTCP = GEQ + gcompare RendezvousTCP RendezvousUDP = GGT +instance GShow R where + gshowsPrec _ RendezvousUDP = showString "UDP" + gshowsPrec _ RendezvousTCP = showString "TCP" + #if MIN_VERSION_dependent_sum(0,6,0) deriveArgDict ''T deriveArgDict ''S deriveArgDict ''O +deriveArgDict ''R #else instance ShowTag T Identity where showTaggedPrec UDP = showsPrec @@ -115,8 +133,15 @@ instance EqTag S Identity where instance OrdTag S Identity where compareTagged SessionUDP SessionUDP = compare compareTagged SessionTCP SessionTCP = compare +instance ShowTag R Identity where + showTaggedPrec RendezvousUDP = showsPrec + showTaggedPrec RendezvousTCP = showsPrec #endif +untagRendezvous :: DSum R Identity -> AnnouncedRendezvous +untagRendezvous (RendezvousUDP :=> Identity o) = o +untagRendezvous (RendezvousTCP :=> Identity o) = o + nodeInfo :: NodeId -> DSum S Identity -> Either String (DSum T Identity) nodeInfo nid (SessionUDP :=> Identity saddr) = fmap (UDP ==>) $ UDP.nodeInfo nid saddr diff --git a/dht/src/Data/Tox/Onion.hs b/dht/src/Data/Tox/Onion.hs index d6f747d9..86fc71f4 100644 --- a/dht/src/Data/Tox/Onion.hs +++ b/dht/src/Data/Tox/Onion.hs @@ -63,6 +63,8 @@ import Data.Word64Map (fitsInInt) import Data.Bits (shiftR,shiftL) import qualified Rank2 import Util (sameAddress) +import Text.XXD +import qualified Data.ByteArray as BA type HandleLo a = Arrival String SockAddr ByteString -> IO a @@ -583,6 +585,7 @@ handleOnionRequest :: forall a proxy n. , KnownPeanoNat n , Sized (ReturnPath n) , Typeable n + , Typeable (ThreeMinus (S n)) ) => proxy n -> TransportCrypto -> (forall x. x -> Addressed x) -> UDPTransport -> IO a -> OnionRequest n -> IO a handleOnionRequest proxy crypto saddr udp kont (OnionRequest nonce msg rpath) = do let n = peanoVal rpath @@ -615,7 +618,7 @@ peelSymmetric :: Serialize (Addressed (ReturnPath n)) peelSymmetric sym (ReturnPath nonce e) = decryptSymmetric sym nonce e >>= decodePlain -peelOnion :: Serialize (Addressed (Forwarding n t)) +peelOnion :: ( Typeable n, Typeable t, Serialize (Addressed (Forwarding n t))) => TransportCrypto -> Nonce24 -> Forwarding (S n) t @@ -766,11 +769,10 @@ data OnionData instance Sized OnionData where size = VarSize $ \case - OnionDHTPublicKey dhtpk -> case size of + OnionDHTPublicKey dhtpk -> 1 + case size of ConstSize n -> n -- Override because OnionData probably -- should be treated as variable sized. VarSize f -> f dhtpk - -- FIXME: inconsitantly, we have to add in the tag byte for this case. OnionFriendRequest req -> 1 + case size of ConstSize n -> n VarSize f -> f req @@ -824,9 +826,15 @@ decrypt crypto msg addr = do -> (IO ∘ Either String ∘ Identity) a decipher = (\n -> decipher1 crypto skey n . left (senderkey addr)) foo <- sequenceMessage $ transcode decipher msg - return $ do - msg <- sequenceMessage foo - Right (msg, addr) + let result = do + msg <- sequenceMessage foo + Right (msg, addr) + case msg of + OnionToRouteResponse {} -> case result of + Left e -> dput XOnion $ "Error decrypting data-to-route response: " ++ e + Right m -> dput XOnion $ "Decrypted data-to-route response: " ++ show (fst m) + _ -> return () + return result senderkey :: OnionDestination r -> t -> (PublicKey, t) senderkey addr e = (onionKey addr, e) @@ -838,7 +846,12 @@ aliasKey crypto (OnionDestination {}) = (onionAliasSecret &&& onionAliasPublic) dhtKey :: TransportCrypto -> (SecretKey,PublicKey) dhtKey crypto = (transportSecret &&& transportPublic) crypto -decryptMessage :: Serialize x => +decodePlainVerbose :: (Typeable a, Serialize a) => Plain Serialize a -> Either String a +decodePlainVerbose p = + left (\e -> unlines (unwords [e , show $ typeRep p] : xxd2 0 (BA.convert p :: ByteString))) + $ decodePlain p + +decryptMessage :: (Typeable x, Serialize x) => TransportCrypto -> (SecretKey,PublicKey) -> Nonce24 @@ -847,7 +860,7 @@ decryptMessage :: Serialize x => -> IO ((Either String ∘ Identity) x) decryptMessage crypto (sk,pk) n arg = do let (sender,e) = either id (senderKey &&& asymmData) arg - plain = Composed . fmap Identity . (>>= decodePlain) + plain = Composed . fmap Identity . (>>= decodePlainVerbose) secret <- lookupSharedSecret crypto sk sender n return $ plain $ ToxCrypto.decrypt secret e @@ -998,15 +1011,15 @@ parseDataToRoute crypto (OnionToRouteResponse dta, od) = do (Right dta) -- using Asymm{senderKey} as remote key let eOuter = fmap runIdentity $ uncomposed omsg0 - anyRight [] f = return $ Left "parseDataToRoute: no user key" - anyRight (x:xs) f = f x >>= either (const $ anyRight xs f) (return . Right) + anyRight [] e f = return $ Left $ "parseDataToRoute: " ++ e + anyRight (x:xs) e f = f x >>= either (\e2 -> anyRight xs e2 f) (return . Right) -- TODO: We don't currently have a way to look up which user key we -- announced using along this onion route. Therefore, for now, we will -- try all our user keys to see if any can decrypt the packet. eInner <- case eOuter of Left e -> return $ Left e - Right dtr -> anyRight ks $ \(sk,pk) -> do + Right dtr -> anyRight ks "no user key" $ \(sk,pk) -> do omsg0 <- decryptMessage crypto (sk,pk) (asymmNonce dta) diff --git a/dht/src/Network/Tox.hs b/dht/src/Network/Tox.hs index 270a9036..1a3bee79 100644 --- a/dht/src/Network/Tox.hs +++ b/dht/src/Network/Tox.hs @@ -315,8 +315,9 @@ newToxOverTransport keydb addr onNewSession (crypto,roster) udp tcp = do let lookupClose _ = return Nothing mkrouting <- DHT.newRouting addr crypto updateIP updateIP - (orouter,relaynet,onioncryptTCP) <- newOnionRouter crypto (dput XRoutes) (maybe False (const True) tcp) - (cryptonet,dhtcrypt,onioncryptUDP,dtacrypt,handshakes) + (orouter,relaynet,onioncryptTCP0) <- newOnionRouter crypto (dput XRoutes) (maybe False (const True) tcp) + (dtacryptTCP,onioncryptTCP) <- partitionTransportM (Onion.parseDataToRoute crypto) (Onion.encodeDataToRoute crypto) onioncryptTCP0 + (cryptonet,dhtcrypt,onioncryptUDP,dtacryptUDP,handshakes) <- toxTransport crypto orouter lookupClose addr udp relaynet (\dst x -> sendMessage (clientNet $ tcpClient $ tcpKademliaClient orouter) dst (True,x)) (fromMaybe (\_ _ -> return ()) tcp) @@ -358,6 +359,10 @@ newToxOverTransport keydb addr onNewSession (crypto,roster) udp tcp = do onioncrypt <- mergeTransports $ DMap.fromList [ Multi.OnionUDP :=> ByAddress onioncryptUDP , Multi.OnionTCP :=> ByAddress {- $ onInbound updateOnTCP -} onioncryptTCP ] + dtacrypt0 <- mergeTransports $ DMap.fromList + [ Multi.RendezvousUDP :=> ByAddress dtacryptUDP + , Multi.RendezvousTCP :=> ByAddress dtacryptTCP + ] oniondrg <- drgNew let onionnet = layerTransportM (\msg od -> Onion.decrypt crypto msg $ Multi.untagOnion od) @@ -373,6 +378,9 @@ newToxOverTransport keydb addr onNewSession (crypto,roster) udp tcp = do _ -> return Nothing return (msg', maybe (Multi.OnionUDP ==> od') (const $ Multi.OnionTCP ==> od') mtcp)) onioncrypt + dtacrypt = layerTransport (\msg addr -> Right (msg,Multi.untagRendezvous addr)) + (\msg addr -> (msg, Multi.RendezvousUDP ==> addr)) + dtacrypt0 onionclient <- newClient oniondrg onionnet (const Onion.classify) (getOnionAlias crypto $ R.thisNode <$> readTVar (DHT.routing4 $ mkrouting dhtclient)) (const $ Onion.handlers onionnet (mkrouting dhtclient) toks keydb) diff --git a/dht/src/Network/Tox/DHT/Transport.hs b/dht/src/Network/Tox/DHT/Transport.hs index ff743f29..9136caeb 100644 --- a/dht/src/Network/Tox/DHT/Transport.hs +++ b/dht/src/Network/Tox/DHT/Transport.hs @@ -292,26 +292,27 @@ instance Serialize LongTermKeyWrap where instance Sized DHTPublicKey where - -- NOTE: 41 bytes includes the 1-byte tag 0x9c in the size. - -- WARNING: Serialize instance does not include this byte FIXME - size = VarSize $ \(DHTPublicKey _ _ nodes) -> 41 + case size of + size = VarSize $ \(DHTPublicKey _ _ nodes) -> 40 + case size of ConstSize nodes -> nodes VarSize sznodes -> sznodes nodes instance Sized Word32 where size = ConstSize 4 --- FIXME: Inconsitently, this type does not include the 0x20 or 0x12 tag byte --- where the DHTPublicKey type does include its tag. instance Sized FriendRequest where size = contramap friendNoSpam size <> contramap friendRequestText (VarSize B.length) +getTCPNodeList :: S.Get [TCP.NodeInfo] +getTCPNodeList = do + n <- S.get + (:) n <$> (getTCPNodeList <|> pure []) + instance Serialize DHTPublicKey where -- TODO: This should agree with Sized instance. - get = DHTPublicKey <$> get <*> getPublicKey <*> get - put (DHTPublicKey nonce key nodes) = do + get = DHTPublicKey <$> get <*> getPublicKey <*> (SendNodes <$> getTCPNodeList) + put (DHTPublicKey nonce key (SendNodes nodes)) = do put nonce putPublicKey key - put nodes + mapM_ put nodes instance Serialize FriendRequest where get = FriendRequest <$> get <*> (remaining >>= getBytes) diff --git a/dht/src/Network/Tox/NodeId.hs b/dht/src/Network/Tox/NodeId.hs index 3a2a4f07..d7ab3316 100644 --- a/dht/src/Network/Tox/NodeId.hs +++ b/dht/src/Network/Tox/NodeId.hs @@ -331,166 +331,6 @@ instance Show NodeInfo where | otherwise = ('[' :) . shows ip . (']' :) - - -{- -type NodeId = PubKey - -pattern NodeId bs = PubKey bs - --- TODO: This should probably be represented by Curve25519.PublicKey, but --- ByteString has more instances... -newtype PubKey = PubKey ByteString - deriving (Eq,Ord,Data, ByteArrayAccess, Bits, Hashable) - -instance Serialize PubKey where - get = PubKey <$> getBytes 32 - put (PubKey bs) = putByteString bs - -instance Show PubKey where - show (PubKey bs) = C8.unpack $ Base16.encode bs - -instance FiniteBits PubKey where - finiteBitSize _ = 256 - -instance Read PubKey where - readsPrec _ str - | (bs, xs) <- Base16.decode $ C8.pack str - , B.length bs == 32 - = [ (PubKey bs, drop 64 str) ] - | otherwise = [] - - - - -data NodeInfo = NodeInfo - { nodeId :: NodeId - , nodeIP :: IP - , nodePort :: PortNumber - } - deriving (Eq,Ord,Data) - -instance Data PortNumber where - dataTypeOf _ = mkNoRepType "PortNumber" - toConstr _ = error "PortNumber.toConstr" - gunfold _ _ = error "PortNumber.gunfold" - -instance ToJSON NodeInfo where - toJSON (NodeInfo nid (IPv4 ip) port) - = JSON.object [ "public_key" .= show nid - , "ipv4" .= show ip - , "port" .= (fromIntegral port :: Int) - ] - toJSON (NodeInfo nid (IPv6 ip6) port) - | Just ip <- un4map ip6 - = JSON.object [ "public_key" .= show nid - , "ipv4" .= show ip - , "port" .= (fromIntegral port :: Int) - ] - | otherwise - = JSON.object [ "public_key" .= show nid - , "ipv6" .= show ip6 - , "port" .= (fromIntegral port :: Int) - ] -instance FromJSON NodeInfo where - parseJSON (JSON.Object v) = do - nidstr <- v JSON..: "public_key" - ip6str <- v JSON..:? "ipv6" - ip4str <- v JSON..:? "ipv4" - portnum <- v JSON..: "port" - ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe) - <|> maybe empty (return . IPv4) (ip4str >>= readMaybe) - let (bs,_) = Base16.decode (C8.pack nidstr) - guard (B.length bs == 32) - return $ NodeInfo (NodeId bs) ip (fromIntegral (portnum :: Word16)) - -getIP :: Word8 -> S.Get IP -getIP 0x02 = IPv4 <$> S.get -getIP 0x0a = IPv6 <$> S.get -getIP 0x82 = IPv4 <$> S.get -- TODO: TCP -getIP 0x8a = IPv6 <$> S.get -- TODO: TCP -getIP x = MF.fail ("unsupported address family ("++show x++")") - -instance S.Serialize NodeInfo where - get = do - addrfam <- S.get :: S.Get Word8 - ip <- getIP addrfam - port <- S.get :: S.Get PortNumber - nid <- S.get - return $ NodeInfo nid ip port - - put (NodeInfo nid ip port) = do - case ip of - IPv4 ip4 -> S.put (2 :: Word8) >> S.put ip4 - IPv6 ip6 -> S.put (10 :: Word8) >> S.put ip6 - S.put port - S.put nid - --- node format: --- [uint8_t family (2 == IPv4, 10 == IPv6, 130 == TCP IPv4, 138 == TCP IPv6)] --- [ip (in network byte order), length=4 bytes if ipv4, 16 bytes if ipv6] --- [port (in network byte order), length=2 bytes] --- [char array (node_id), length=32 bytes] --- - - -hexdigit :: Char -> Bool -hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F') - -instance Read NodeInfo where - readsPrec i = RP.readP_to_S $ do - RP.skipSpaces - let n = 64 -- characters in node id. - parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')')) - RP.+++ RP.munch (not . isSpace) - nodeidAt = do hexhash <- sequence $ replicate n (RP.satisfy hexdigit) - RP.char '@' RP.+++ RP.satisfy isSpace - addrstr <- parseAddr - nid <- case Base16.decode $ C8.pack hexhash of - (bs,_) | B.length bs==32 -> return (PubKey bs) - _ -> MF.fail "Bad node id." - return (nid,addrstr) - (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) ) - let raddr = do - ip <- RP.between (RP.char '[') (RP.char ']') - (IPv6 <$> RP.readS_to_P (readsPrec i)) - RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i)) - _ <- RP.char ':' - port <- toEnum <$> RP.readS_to_P (readsPrec i) - return (ip, port) - - (ip,port) <- case RP.readP_to_S raddr addrstr of - [] -> MF.fail "Bad address." - ((ip,port),_):_ -> return (ip,port) - return $ NodeInfo nid ip port - - --- The Hashable instance depends only on the IP address and port number. -instance Hashable NodeInfo where - hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni) - {-# INLINE hashWithSalt #-} - - -instance Show NodeInfo where - showsPrec _ (NodeInfo nid ip port) = - shows nid . ('@' :) . showsip . (':' :) . shows port - where - showsip - | IPv4 ip4 <- ip = shows ip4 - | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4 - | otherwise = ('[' :) . shows ip . (']' :) - -nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo -nodeInfo nid saddr - | Just ip <- fromSockAddr saddr - , Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port - | otherwise = Left "Address family not supported." - -zeroID :: NodeId -zeroID = PubKey $ B.replicate 32 0 - --} - nodeAddr :: NodeInfo -> SockAddr nodeAddr (NodeInfo _ ip port) = setPort port $ toSockAddr ip @@ -498,13 +338,6 @@ nodeAddr (NodeInfo _ ip port) = setPort port $ toSockAddr ip newtype ForwardPath (n::Nat) = ForwardPath ByteString deriving (Eq, Ord,Data) -{- -class KnownNat n => OnionPacket n where - mkOnion :: ReturnPath n -> Packet -> Packet -instance OnionPacket 0 where mkOnion _ = id -instance OnionPacket 3 where mkOnion = OnionResponse3 --} - data NoSpam = NoSpam !Word32 !(Maybe Word16) deriving (Eq,Ord,Show) diff --git a/dht/src/Network/Tox/TCP.hs b/dht/src/Network/Tox/TCP.hs index a37c0310..cb0f0a1b 100644 --- a/dht/src/Network/Tox/TCP.hs +++ b/dht/src/Network/Tox/TCP.hs @@ -456,7 +456,8 @@ partitionOnion crypto lookupSender getRoute tr = partitionTransportM parse encod case m of Nothing -> return $ Right pass Just od -> return $ Left (msg, od) - parse ((_,OnionPacketResponse msg@(OnionToRouteResponse asym)), nodeA) = + parse ((_,OnionPacketResponse msg@(OnionToRouteResponse asym)), nodeA) = do + -- dput XOnion $ "TCP data-to-route response from " ++ show (UDP.key2id $ senderKey asym) return $ let Right ni = UDP.nodeInfo (UDP.key2id $ senderKey asym) nullAddress4 -- -- We have this information, but currently, we're discarding it... diff --git a/dht/src/Network/Tox/Transport.hs b/dht/src/Network/Tox/Transport.hs index ff99b747..55e31e2a 100644 --- a/dht/src/Network/Tox/Transport.hs +++ b/dht/src/Network/Tox/Transport.hs @@ -48,13 +48,14 @@ toxTransport :: toxTransport crypto orouter closeLookup addr udp relaynet _ tcp2client = do (netcrypto, udp0) <- partitionTransport parseCrypto encodeCrypto udp (dhtUDP,udp1) <- partitionTransportM (parseDHTAddr (pendingCookiesUDP crypto) nodeInfo) - (fmap Just . encodeDHTAddr nodeAddr) + (fmap Just . encodeDHTAddr nodeAddr) $ forwardOnions crypto addr udp0 tcp2client -- rlynet0 = layerTransportM (DHT.decrypt crypto Multi.relayNodeId) (DHT.encrypt crypto Multi.relayNodeId) relaynet - (dhtTCP,relaynet0) <- partitionTransportM + (netcryptoTCP, relaynet0) <- partitionTransport parseCrypto encodeCrypto relaynet + (dhtTCP,relaynet1) <- partitionTransportM (parseDHTAddr (pendingCookiesTCP crypto) (\nid viarelay -> Right viarelay)) (fmap Just . encodeDHTAddr id) - relaynet + relaynet0 let _ = dhtTCP :: Transport String ViaRelay (DHTMessage Encrypted8) dht <- mergeTransports $ DMap.fromList [ Multi.UDP :=> ByAddress dhtUDP @@ -65,7 +66,6 @@ toxTransport crypto orouter closeLookup addr udp relaynet _ tcp2client = do (encodeOnionAddr crypto $ lookupRoute orouter) udp1 (dta,onion) <- partitionTransportM (parseDataToRoute crypto) (encodeDataToRoute crypto) onion1 - (netcryptoTCP, relaynet1) <- partitionTransport parseCrypto encodeCrypto relaynet0 multi_netcrypto <- mergeTransports $ DMap.fromList [ Multi.SessionUDP :=> ByAddress netcrypto , Multi.SessionTCP :=> ByAddress netcryptoTCP ] -- cgit v1.2.3