diff options
author | Joe Crayne <joe@jerkface.net> | 2020-01-10 02:51:51 -0500 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2020-01-10 02:51:51 -0500 |
commit | 8df4213da5b8ff9faff6194a06bd2c9c00dbad16 (patch) | |
tree | 53b234d79175a28a0b36aae11a34a5b395df2376 | |
parent | 8ddaf16880b3dcc8cb30a36c46c7edd1f9fe4b3c (diff) |
First successful TCP relay mediated chat link!
-rw-r--r-- | dht/src/Data/Tox/DHT/Multi.hs | 39 | ||||
-rw-r--r-- | dht/src/Data/Tox/Onion.hs | 35 | ||||
-rw-r--r-- | dht/src/Network/Tox.hs | 12 | ||||
-rw-r--r-- | dht/src/Network/Tox/DHT/Transport.hs | 17 | ||||
-rw-r--r-- | dht/src/Network/Tox/NodeId.hs | 167 | ||||
-rw-r--r-- | dht/src/Network/Tox/TCP.hs | 3 | ||||
-rw-r--r-- | 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) | |||
11 | import qualified Network.Tox.NodeId as UDP | 11 | import qualified Network.Tox.NodeId as UDP |
12 | ;import Network.Tox.NodeId (NodeId) | 12 | ;import Network.Tox.NodeId (NodeId) |
13 | import qualified Network.Tox.TCP.NodeId as TCP | 13 | import qualified Network.Tox.TCP.NodeId as TCP |
14 | import Data.Tox.Onion (OnionDestination,RouteId) | 14 | import Data.Tox.Onion (OnionDestination,RouteId,AnnouncedRendezvous) |
15 | import Data.Tox.Relay hiding (NodeInfo) | 15 | import Data.Tox.Relay hiding (NodeInfo) |
16 | import Network.Address (either4or6) | 16 | import Network.Address (either4or6) |
17 | import Network.Tox.TCP as TCP (ViaRelay(..), tcpConnectionRequest_) | 17 | import Network.Tox.TCP as TCP (ViaRelay(..), tcpConnectionRequest_) |
@@ -45,8 +45,8 @@ instance GCompare T where | |||
45 | gcompare TCP TCP = GEQ | 45 | gcompare TCP TCP = GEQ |
46 | gcompare TCP UDP = GGT | 46 | gcompare TCP UDP = GGT |
47 | instance GShow T where | 47 | instance GShow T where |
48 | gshowsPrec _ UDP = showString "UDP" | 48 | gshowsPrec _ UDP = showString "UDP" |
49 | gshowsPrec _ TCP = showString "TCP" | 49 | gshowsPrec _ TCP = showString "TCP" |
50 | 50 | ||
51 | data S addr where | 51 | data S addr where |
52 | SessionUDP :: S SockAddr | 52 | SessionUDP :: S SockAddr |
@@ -62,8 +62,8 @@ instance GCompare S where | |||
62 | gcompare SessionTCP SessionTCP = GEQ | 62 | gcompare SessionTCP SessionTCP = GEQ |
63 | gcompare SessionTCP SessionUDP = GGT | 63 | gcompare SessionTCP SessionUDP = GGT |
64 | instance GShow S where | 64 | instance GShow S where |
65 | gshowsPrec _ SessionUDP = showString "UDP" | 65 | gshowsPrec _ SessionUDP = showString "UDP" |
66 | gshowsPrec _ SessionTCP = showString "TCP" | 66 | gshowsPrec _ SessionTCP = showString "TCP" |
67 | 67 | ||
68 | data O addr where | 68 | data O addr where |
69 | OnionUDP :: O (OnionDestination RouteId) | 69 | OnionUDP :: O (OnionDestination RouteId) |
@@ -79,8 +79,8 @@ instance GCompare O where | |||
79 | gcompare OnionTCP OnionTCP = GEQ | 79 | gcompare OnionTCP OnionTCP = GEQ |
80 | gcompare OnionTCP OnionUDP = GGT | 80 | gcompare OnionTCP OnionUDP = GGT |
81 | instance GShow O where | 81 | instance GShow O where |
82 | gshowsPrec _ OnionUDP = showString "UDP" | 82 | gshowsPrec _ OnionUDP = showString "UDP" |
83 | gshowsPrec _ OnionTCP = showString "TCP" | 83 | gshowsPrec _ OnionTCP = showString "TCP" |
84 | 84 | ||
85 | untagOnion :: DSum O Identity -> OnionDestination RouteId | 85 | untagOnion :: DSum O Identity -> OnionDestination RouteId |
86 | untagOnion (OnionUDP :=> Identity o) = o | 86 | untagOnion (OnionUDP :=> Identity o) = o |
@@ -95,10 +95,28 @@ type NodeInfo = DSum T Identity | |||
95 | type SessionAddress = DSum S Identity | 95 | type SessionAddress = DSum S Identity |
96 | type OnionAddress = DSum O Identity | 96 | type OnionAddress = DSum O Identity |
97 | 97 | ||
98 | data R addr where | ||
99 | RendezvousUDP :: R AnnouncedRendezvous | ||
100 | RendezvousTCP :: R AnnouncedRendezvous | ||
101 | |||
102 | instance GEq R where | ||
103 | geq RendezvousUDP RendezvousUDP = Just Refl | ||
104 | geq RendezvousTCP RendezvousTCP = Just Refl | ||
105 | geq _ _ = Nothing | ||
106 | instance GCompare R where | ||
107 | gcompare RendezvousUDP RendezvousUDP = GEQ | ||
108 | gcompare RendezvousUDP RendezvousTCP = GLT | ||
109 | gcompare RendezvousTCP RendezvousTCP = GEQ | ||
110 | gcompare RendezvousTCP RendezvousUDP = GGT | ||
111 | instance GShow R where | ||
112 | gshowsPrec _ RendezvousUDP = showString "UDP" | ||
113 | gshowsPrec _ RendezvousTCP = showString "TCP" | ||
114 | |||
98 | #if MIN_VERSION_dependent_sum(0,6,0) | 115 | #if MIN_VERSION_dependent_sum(0,6,0) |
99 | deriveArgDict ''T | 116 | deriveArgDict ''T |
100 | deriveArgDict ''S | 117 | deriveArgDict ''S |
101 | deriveArgDict ''O | 118 | deriveArgDict ''O |
119 | deriveArgDict ''R | ||
102 | #else | 120 | #else |
103 | instance ShowTag T Identity where | 121 | instance ShowTag T Identity where |
104 | showTaggedPrec UDP = showsPrec | 122 | showTaggedPrec UDP = showsPrec |
@@ -115,8 +133,15 @@ instance EqTag S Identity where | |||
115 | instance OrdTag S Identity where | 133 | instance OrdTag S Identity where |
116 | compareTagged SessionUDP SessionUDP = compare | 134 | compareTagged SessionUDP SessionUDP = compare |
117 | compareTagged SessionTCP SessionTCP = compare | 135 | compareTagged SessionTCP SessionTCP = compare |
136 | instance ShowTag R Identity where | ||
137 | showTaggedPrec RendezvousUDP = showsPrec | ||
138 | showTaggedPrec RendezvousTCP = showsPrec | ||
118 | #endif | 139 | #endif |
119 | 140 | ||
141 | untagRendezvous :: DSum R Identity -> AnnouncedRendezvous | ||
142 | untagRendezvous (RendezvousUDP :=> Identity o) = o | ||
143 | untagRendezvous (RendezvousTCP :=> Identity o) = o | ||
144 | |||
120 | 145 | ||
121 | nodeInfo :: NodeId -> DSum S Identity -> Either String (DSum T Identity) | 146 | nodeInfo :: NodeId -> DSum S Identity -> Either String (DSum T Identity) |
122 | nodeInfo nid (SessionUDP :=> Identity saddr) = fmap (UDP ==>) $ UDP.nodeInfo nid saddr | 147 | 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) | |||
63 | import Data.Bits (shiftR,shiftL) | 63 | import Data.Bits (shiftR,shiftL) |
64 | import qualified Rank2 | 64 | import qualified Rank2 |
65 | import Util (sameAddress) | 65 | import Util (sameAddress) |
66 | import Text.XXD | ||
67 | import qualified Data.ByteArray as BA | ||
66 | 68 | ||
67 | type HandleLo a = Arrival String SockAddr ByteString -> IO a | 69 | type HandleLo a = Arrival String SockAddr ByteString -> IO a |
68 | 70 | ||
@@ -583,6 +585,7 @@ handleOnionRequest :: forall a proxy n. | |||
583 | , KnownPeanoNat n | 585 | , KnownPeanoNat n |
584 | , Sized (ReturnPath n) | 586 | , Sized (ReturnPath n) |
585 | , Typeable n | 587 | , Typeable n |
588 | , Typeable (ThreeMinus (S n)) | ||
586 | ) => proxy n -> TransportCrypto -> (forall x. x -> Addressed x) -> UDPTransport -> IO a -> OnionRequest n -> IO a | 589 | ) => proxy n -> TransportCrypto -> (forall x. x -> Addressed x) -> UDPTransport -> IO a -> OnionRequest n -> IO a |
587 | handleOnionRequest proxy crypto saddr udp kont (OnionRequest nonce msg rpath) = do | 590 | handleOnionRequest proxy crypto saddr udp kont (OnionRequest nonce msg rpath) = do |
588 | let n = peanoVal rpath | 591 | let n = peanoVal rpath |
@@ -615,7 +618,7 @@ peelSymmetric :: Serialize (Addressed (ReturnPath n)) | |||
615 | peelSymmetric sym (ReturnPath nonce e) = decryptSymmetric sym nonce e >>= decodePlain | 618 | peelSymmetric sym (ReturnPath nonce e) = decryptSymmetric sym nonce e >>= decodePlain |
616 | 619 | ||
617 | 620 | ||
618 | peelOnion :: Serialize (Addressed (Forwarding n t)) | 621 | peelOnion :: ( Typeable n, Typeable t, Serialize (Addressed (Forwarding n t))) |
619 | => TransportCrypto | 622 | => TransportCrypto |
620 | -> Nonce24 | 623 | -> Nonce24 |
621 | -> Forwarding (S n) t | 624 | -> Forwarding (S n) t |
@@ -766,11 +769,10 @@ data OnionData | |||
766 | 769 | ||
767 | instance Sized OnionData where | 770 | instance Sized OnionData where |
768 | size = VarSize $ \case | 771 | size = VarSize $ \case |
769 | OnionDHTPublicKey dhtpk -> case size of | 772 | OnionDHTPublicKey dhtpk -> 1 + case size of |
770 | ConstSize n -> n -- Override because OnionData probably | 773 | ConstSize n -> n -- Override because OnionData probably |
771 | -- should be treated as variable sized. | 774 | -- should be treated as variable sized. |
772 | VarSize f -> f dhtpk | 775 | VarSize f -> f dhtpk |
773 | -- FIXME: inconsitantly, we have to add in the tag byte for this case. | ||
774 | OnionFriendRequest req -> 1 + case size of | 776 | OnionFriendRequest req -> 1 + case size of |
775 | ConstSize n -> n | 777 | ConstSize n -> n |
776 | VarSize f -> f req | 778 | VarSize f -> f req |
@@ -824,9 +826,15 @@ decrypt crypto msg addr = do | |||
824 | -> (IO ∘ Either String ∘ Identity) a | 826 | -> (IO ∘ Either String ∘ Identity) a |
825 | decipher = (\n -> decipher1 crypto skey n . left (senderkey addr)) | 827 | decipher = (\n -> decipher1 crypto skey n . left (senderkey addr)) |
826 | foo <- sequenceMessage $ transcode decipher msg | 828 | foo <- sequenceMessage $ transcode decipher msg |
827 | return $ do | 829 | let result = do |
828 | msg <- sequenceMessage foo | 830 | msg <- sequenceMessage foo |
829 | Right (msg, addr) | 831 | Right (msg, addr) |
832 | case msg of | ||
833 | OnionToRouteResponse {} -> case result of | ||
834 | Left e -> dput XOnion $ "Error decrypting data-to-route response: " ++ e | ||
835 | Right m -> dput XOnion $ "Decrypted data-to-route response: " ++ show (fst m) | ||
836 | _ -> return () | ||
837 | return result | ||
830 | 838 | ||
831 | senderkey :: OnionDestination r -> t -> (PublicKey, t) | 839 | senderkey :: OnionDestination r -> t -> (PublicKey, t) |
832 | senderkey addr e = (onionKey addr, e) | 840 | senderkey addr e = (onionKey addr, e) |
@@ -838,7 +846,12 @@ aliasKey crypto (OnionDestination {}) = (onionAliasSecret &&& onionAliasPublic) | |||
838 | dhtKey :: TransportCrypto -> (SecretKey,PublicKey) | 846 | dhtKey :: TransportCrypto -> (SecretKey,PublicKey) |
839 | dhtKey crypto = (transportSecret &&& transportPublic) crypto | 847 | dhtKey crypto = (transportSecret &&& transportPublic) crypto |
840 | 848 | ||
841 | decryptMessage :: Serialize x => | 849 | decodePlainVerbose :: (Typeable a, Serialize a) => Plain Serialize a -> Either String a |
850 | decodePlainVerbose p = | ||
851 | left (\e -> unlines (unwords [e , show $ typeRep p] : xxd2 0 (BA.convert p :: ByteString))) | ||
852 | $ decodePlain p | ||
853 | |||
854 | decryptMessage :: (Typeable x, Serialize x) => | ||
842 | TransportCrypto | 855 | TransportCrypto |
843 | -> (SecretKey,PublicKey) | 856 | -> (SecretKey,PublicKey) |
844 | -> Nonce24 | 857 | -> Nonce24 |
@@ -847,7 +860,7 @@ decryptMessage :: Serialize x => | |||
847 | -> IO ((Either String ∘ Identity) x) | 860 | -> IO ((Either String ∘ Identity) x) |
848 | decryptMessage crypto (sk,pk) n arg = do | 861 | decryptMessage crypto (sk,pk) n arg = do |
849 | let (sender,e) = either id (senderKey &&& asymmData) arg | 862 | let (sender,e) = either id (senderKey &&& asymmData) arg |
850 | plain = Composed . fmap Identity . (>>= decodePlain) | 863 | plain = Composed . fmap Identity . (>>= decodePlainVerbose) |
851 | secret <- lookupSharedSecret crypto sk sender n | 864 | secret <- lookupSharedSecret crypto sk sender n |
852 | return $ plain $ ToxCrypto.decrypt secret e | 865 | return $ plain $ ToxCrypto.decrypt secret e |
853 | 866 | ||
@@ -998,15 +1011,15 @@ parseDataToRoute crypto (OnionToRouteResponse dta, od) = do | |||
998 | (Right dta) -- using Asymm{senderKey} as remote key | 1011 | (Right dta) -- using Asymm{senderKey} as remote key |
999 | let eOuter = fmap runIdentity $ uncomposed omsg0 | 1012 | let eOuter = fmap runIdentity $ uncomposed omsg0 |
1000 | 1013 | ||
1001 | anyRight [] f = return $ Left "parseDataToRoute: no user key" | 1014 | anyRight [] e f = return $ Left $ "parseDataToRoute: " ++ e |
1002 | anyRight (x:xs) f = f x >>= either (const $ anyRight xs f) (return . Right) | 1015 | anyRight (x:xs) e f = f x >>= either (\e2 -> anyRight xs e2 f) (return . Right) |
1003 | 1016 | ||
1004 | -- TODO: We don't currently have a way to look up which user key we | 1017 | -- TODO: We don't currently have a way to look up which user key we |
1005 | -- announced using along this onion route. Therefore, for now, we will | 1018 | -- announced using along this onion route. Therefore, for now, we will |
1006 | -- try all our user keys to see if any can decrypt the packet. | 1019 | -- try all our user keys to see if any can decrypt the packet. |
1007 | eInner <- case eOuter of | 1020 | eInner <- case eOuter of |
1008 | Left e -> return $ Left e | 1021 | Left e -> return $ Left e |
1009 | Right dtr -> anyRight ks $ \(sk,pk) -> do | 1022 | Right dtr -> anyRight ks "no user key" $ \(sk,pk) -> do |
1010 | omsg0 <- decryptMessage crypto | 1023 | omsg0 <- decryptMessage crypto |
1011 | (sk,pk) | 1024 | (sk,pk) |
1012 | (asymmNonce dta) | 1025 | (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 | |||
315 | let lookupClose _ = return Nothing | 315 | let lookupClose _ = return Nothing |
316 | 316 | ||
317 | mkrouting <- DHT.newRouting addr crypto updateIP updateIP | 317 | mkrouting <- DHT.newRouting addr crypto updateIP updateIP |
318 | (orouter,relaynet,onioncryptTCP) <- newOnionRouter crypto (dput XRoutes) (maybe False (const True) tcp) | 318 | (orouter,relaynet,onioncryptTCP0) <- newOnionRouter crypto (dput XRoutes) (maybe False (const True) tcp) |
319 | (cryptonet,dhtcrypt,onioncryptUDP,dtacrypt,handshakes) | 319 | (dtacryptTCP,onioncryptTCP) <- partitionTransportM (Onion.parseDataToRoute crypto) (Onion.encodeDataToRoute crypto) onioncryptTCP0 |
320 | (cryptonet,dhtcrypt,onioncryptUDP,dtacryptUDP,handshakes) | ||
320 | <- toxTransport crypto orouter lookupClose addr udp relaynet | 321 | <- toxTransport crypto orouter lookupClose addr udp relaynet |
321 | (\dst x -> sendMessage (clientNet $ tcpClient $ tcpKademliaClient orouter) dst (True,x)) | 322 | (\dst x -> sendMessage (clientNet $ tcpClient $ tcpKademliaClient orouter) dst (True,x)) |
322 | (fromMaybe (\_ _ -> return ()) tcp) | 323 | (fromMaybe (\_ _ -> return ()) tcp) |
@@ -358,6 +359,10 @@ newToxOverTransport keydb addr onNewSession (crypto,roster) udp tcp = do | |||
358 | onioncrypt <- mergeTransports $ DMap.fromList | 359 | onioncrypt <- mergeTransports $ DMap.fromList |
359 | [ Multi.OnionUDP :=> ByAddress onioncryptUDP | 360 | [ Multi.OnionUDP :=> ByAddress onioncryptUDP |
360 | , Multi.OnionTCP :=> ByAddress {- $ onInbound updateOnTCP -} onioncryptTCP ] | 361 | , Multi.OnionTCP :=> ByAddress {- $ onInbound updateOnTCP -} onioncryptTCP ] |
362 | dtacrypt0 <- mergeTransports $ DMap.fromList | ||
363 | [ Multi.RendezvousUDP :=> ByAddress dtacryptUDP | ||
364 | , Multi.RendezvousTCP :=> ByAddress dtacryptTCP | ||
365 | ] | ||
361 | oniondrg <- drgNew | 366 | oniondrg <- drgNew |
362 | let onionnet = layerTransportM | 367 | let onionnet = layerTransportM |
363 | (\msg od -> Onion.decrypt crypto msg $ Multi.untagOnion od) | 368 | (\msg od -> Onion.decrypt crypto msg $ Multi.untagOnion od) |
@@ -373,6 +378,9 @@ newToxOverTransport keydb addr onNewSession (crypto,roster) udp tcp = do | |||
373 | _ -> return Nothing | 378 | _ -> return Nothing |
374 | return (msg', maybe (Multi.OnionUDP ==> od') (const $ Multi.OnionTCP ==> od') mtcp)) | 379 | return (msg', maybe (Multi.OnionUDP ==> od') (const $ Multi.OnionTCP ==> od') mtcp)) |
375 | onioncrypt | 380 | onioncrypt |
381 | dtacrypt = layerTransport (\msg addr -> Right (msg,Multi.untagRendezvous addr)) | ||
382 | (\msg addr -> (msg, Multi.RendezvousUDP ==> addr)) | ||
383 | dtacrypt0 | ||
376 | onionclient <- newClient oniondrg onionnet (const Onion.classify) | 384 | onionclient <- newClient oniondrg onionnet (const Onion.classify) |
377 | (getOnionAlias crypto $ R.thisNode <$> readTVar (DHT.routing4 $ mkrouting dhtclient)) | 385 | (getOnionAlias crypto $ R.thisNode <$> readTVar (DHT.routing4 $ mkrouting dhtclient)) |
378 | (const $ Onion.handlers onionnet (mkrouting dhtclient) toks keydb) | 386 | (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 | |||
292 | 292 | ||
293 | 293 | ||
294 | instance Sized DHTPublicKey where | 294 | instance Sized DHTPublicKey where |
295 | -- NOTE: 41 bytes includes the 1-byte tag 0x9c in the size. | 295 | size = VarSize $ \(DHTPublicKey _ _ nodes) -> 40 + case size of |
296 | -- WARNING: Serialize instance does not include this byte FIXME | ||
297 | size = VarSize $ \(DHTPublicKey _ _ nodes) -> 41 + case size of | ||
298 | ConstSize nodes -> nodes | 296 | ConstSize nodes -> nodes |
299 | VarSize sznodes -> sznodes nodes | 297 | VarSize sznodes -> sznodes nodes |
300 | 298 | ||
301 | instance Sized Word32 where size = ConstSize 4 | 299 | instance Sized Word32 where size = ConstSize 4 |
302 | 300 | ||
303 | -- FIXME: Inconsitently, this type does not include the 0x20 or 0x12 tag byte | ||
304 | -- where the DHTPublicKey type does include its tag. | ||
305 | instance Sized FriendRequest where | 301 | instance Sized FriendRequest where |
306 | size = contramap friendNoSpam size <> contramap friendRequestText (VarSize B.length) | 302 | size = contramap friendNoSpam size <> contramap friendRequestText (VarSize B.length) |
307 | 303 | ||
304 | getTCPNodeList :: S.Get [TCP.NodeInfo] | ||
305 | getTCPNodeList = do | ||
306 | n <- S.get | ||
307 | (:) n <$> (getTCPNodeList <|> pure []) | ||
308 | |||
308 | instance Serialize DHTPublicKey where | 309 | instance Serialize DHTPublicKey where |
309 | -- TODO: This should agree with Sized instance. | 310 | -- TODO: This should agree with Sized instance. |
310 | get = DHTPublicKey <$> get <*> getPublicKey <*> get | 311 | get = DHTPublicKey <$> get <*> getPublicKey <*> (SendNodes <$> getTCPNodeList) |
311 | put (DHTPublicKey nonce key nodes) = do | 312 | put (DHTPublicKey nonce key (SendNodes nodes)) = do |
312 | put nonce | 313 | put nonce |
313 | putPublicKey key | 314 | putPublicKey key |
314 | put nodes | 315 | mapM_ put nodes |
315 | 316 | ||
316 | instance Serialize FriendRequest where | 317 | instance Serialize FriendRequest where |
317 | get = FriendRequest <$> get <*> (remaining >>= getBytes) | 318 | 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 | |||
331 | | otherwise = ('[' :) . shows ip . (']' :) | 331 | | otherwise = ('[' :) . shows ip . (']' :) |
332 | 332 | ||
333 | 333 | ||
334 | |||
335 | |||
336 | {- | ||
337 | type NodeId = PubKey | ||
338 | |||
339 | pattern NodeId bs = PubKey bs | ||
340 | |||
341 | -- TODO: This should probably be represented by Curve25519.PublicKey, but | ||
342 | -- ByteString has more instances... | ||
343 | newtype PubKey = PubKey ByteString | ||
344 | deriving (Eq,Ord,Data, ByteArrayAccess, Bits, Hashable) | ||
345 | |||
346 | instance Serialize PubKey where | ||
347 | get = PubKey <$> getBytes 32 | ||
348 | put (PubKey bs) = putByteString bs | ||
349 | |||
350 | instance Show PubKey where | ||
351 | show (PubKey bs) = C8.unpack $ Base16.encode bs | ||
352 | |||
353 | instance FiniteBits PubKey where | ||
354 | finiteBitSize _ = 256 | ||
355 | |||
356 | instance Read PubKey where | ||
357 | readsPrec _ str | ||
358 | | (bs, xs) <- Base16.decode $ C8.pack str | ||
359 | , B.length bs == 32 | ||
360 | = [ (PubKey bs, drop 64 str) ] | ||
361 | | otherwise = [] | ||
362 | |||
363 | |||
364 | |||
365 | |||
366 | data NodeInfo = NodeInfo | ||
367 | { nodeId :: NodeId | ||
368 | , nodeIP :: IP | ||
369 | , nodePort :: PortNumber | ||
370 | } | ||
371 | deriving (Eq,Ord,Data) | ||
372 | |||
373 | instance Data PortNumber where | ||
374 | dataTypeOf _ = mkNoRepType "PortNumber" | ||
375 | toConstr _ = error "PortNumber.toConstr" | ||
376 | gunfold _ _ = error "PortNumber.gunfold" | ||
377 | |||
378 | instance ToJSON NodeInfo where | ||
379 | toJSON (NodeInfo nid (IPv4 ip) port) | ||
380 | = JSON.object [ "public_key" .= show nid | ||
381 | , "ipv4" .= show ip | ||
382 | , "port" .= (fromIntegral port :: Int) | ||
383 | ] | ||
384 | toJSON (NodeInfo nid (IPv6 ip6) port) | ||
385 | | Just ip <- un4map ip6 | ||
386 | = JSON.object [ "public_key" .= show nid | ||
387 | , "ipv4" .= show ip | ||
388 | , "port" .= (fromIntegral port :: Int) | ||
389 | ] | ||
390 | | otherwise | ||
391 | = JSON.object [ "public_key" .= show nid | ||
392 | , "ipv6" .= show ip6 | ||
393 | , "port" .= (fromIntegral port :: Int) | ||
394 | ] | ||
395 | instance FromJSON NodeInfo where | ||
396 | parseJSON (JSON.Object v) = do | ||
397 | nidstr <- v JSON..: "public_key" | ||
398 | ip6str <- v JSON..:? "ipv6" | ||
399 | ip4str <- v JSON..:? "ipv4" | ||
400 | portnum <- v JSON..: "port" | ||
401 | ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe) | ||
402 | <|> maybe empty (return . IPv4) (ip4str >>= readMaybe) | ||
403 | let (bs,_) = Base16.decode (C8.pack nidstr) | ||
404 | guard (B.length bs == 32) | ||
405 | return $ NodeInfo (NodeId bs) ip (fromIntegral (portnum :: Word16)) | ||
406 | |||
407 | getIP :: Word8 -> S.Get IP | ||
408 | getIP 0x02 = IPv4 <$> S.get | ||
409 | getIP 0x0a = IPv6 <$> S.get | ||
410 | getIP 0x82 = IPv4 <$> S.get -- TODO: TCP | ||
411 | getIP 0x8a = IPv6 <$> S.get -- TODO: TCP | ||
412 | getIP x = MF.fail ("unsupported address family ("++show x++")") | ||
413 | |||
414 | instance S.Serialize NodeInfo where | ||
415 | get = do | ||
416 | addrfam <- S.get :: S.Get Word8 | ||
417 | ip <- getIP addrfam | ||
418 | port <- S.get :: S.Get PortNumber | ||
419 | nid <- S.get | ||
420 | return $ NodeInfo nid ip port | ||
421 | |||
422 | put (NodeInfo nid ip port) = do | ||
423 | case ip of | ||
424 | IPv4 ip4 -> S.put (2 :: Word8) >> S.put ip4 | ||
425 | IPv6 ip6 -> S.put (10 :: Word8) >> S.put ip6 | ||
426 | S.put port | ||
427 | S.put nid | ||
428 | |||
429 | -- node format: | ||
430 | -- [uint8_t family (2 == IPv4, 10 == IPv6, 130 == TCP IPv4, 138 == TCP IPv6)] | ||
431 | -- [ip (in network byte order), length=4 bytes if ipv4, 16 bytes if ipv6] | ||
432 | -- [port (in network byte order), length=2 bytes] | ||
433 | -- [char array (node_id), length=32 bytes] | ||
434 | -- | ||
435 | |||
436 | |||
437 | hexdigit :: Char -> Bool | ||
438 | hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F') | ||
439 | |||
440 | instance Read NodeInfo where | ||
441 | readsPrec i = RP.readP_to_S $ do | ||
442 | RP.skipSpaces | ||
443 | let n = 64 -- characters in node id. | ||
444 | parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')')) | ||
445 | RP.+++ RP.munch (not . isSpace) | ||
446 | nodeidAt = do hexhash <- sequence $ replicate n (RP.satisfy hexdigit) | ||
447 | RP.char '@' RP.+++ RP.satisfy isSpace | ||
448 | addrstr <- parseAddr | ||
449 | nid <- case Base16.decode $ C8.pack hexhash of | ||
450 | (bs,_) | B.length bs==32 -> return (PubKey bs) | ||
451 | _ -> MF.fail "Bad node id." | ||
452 | return (nid,addrstr) | ||
453 | (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) ) | ||
454 | let raddr = do | ||
455 | ip <- RP.between (RP.char '[') (RP.char ']') | ||
456 | (IPv6 <$> RP.readS_to_P (readsPrec i)) | ||
457 | RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i)) | ||
458 | _ <- RP.char ':' | ||
459 | port <- toEnum <$> RP.readS_to_P (readsPrec i) | ||
460 | return (ip, port) | ||
461 | |||
462 | (ip,port) <- case RP.readP_to_S raddr addrstr of | ||
463 | [] -> MF.fail "Bad address." | ||
464 | ((ip,port),_):_ -> return (ip,port) | ||
465 | return $ NodeInfo nid ip port | ||
466 | |||
467 | |||
468 | -- The Hashable instance depends only on the IP address and port number. | ||
469 | instance Hashable NodeInfo where | ||
470 | hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni) | ||
471 | {-# INLINE hashWithSalt #-} | ||
472 | |||
473 | |||
474 | instance Show NodeInfo where | ||
475 | showsPrec _ (NodeInfo nid ip port) = | ||
476 | shows nid . ('@' :) . showsip . (':' :) . shows port | ||
477 | where | ||
478 | showsip | ||
479 | | IPv4 ip4 <- ip = shows ip4 | ||
480 | | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4 | ||
481 | | otherwise = ('[' :) . shows ip . (']' :) | ||
482 | |||
483 | nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo | ||
484 | nodeInfo nid saddr | ||
485 | | Just ip <- fromSockAddr saddr | ||
486 | , Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port | ||
487 | | otherwise = Left "Address family not supported." | ||
488 | |||
489 | zeroID :: NodeId | ||
490 | zeroID = PubKey $ B.replicate 32 0 | ||
491 | |||
492 | -} | ||
493 | |||
494 | nodeAddr :: NodeInfo -> SockAddr | 334 | nodeAddr :: NodeInfo -> SockAddr |
495 | nodeAddr (NodeInfo _ ip port) = setPort port $ toSockAddr ip | 335 | nodeAddr (NodeInfo _ ip port) = setPort port $ toSockAddr ip |
496 | 336 | ||
@@ -498,13 +338,6 @@ nodeAddr (NodeInfo _ ip port) = setPort port $ toSockAddr ip | |||
498 | newtype ForwardPath (n::Nat) = ForwardPath ByteString | 338 | newtype ForwardPath (n::Nat) = ForwardPath ByteString |
499 | deriving (Eq, Ord,Data) | 339 | deriving (Eq, Ord,Data) |
500 | 340 | ||
501 | {- | ||
502 | class KnownNat n => OnionPacket n where | ||
503 | mkOnion :: ReturnPath n -> Packet -> Packet | ||
504 | instance OnionPacket 0 where mkOnion _ = id | ||
505 | instance OnionPacket 3 where mkOnion = OnionResponse3 | ||
506 | -} | ||
507 | |||
508 | data NoSpam = NoSpam !Word32 !(Maybe Word16) | 341 | data NoSpam = NoSpam !Word32 !(Maybe Word16) |
509 | deriving (Eq,Ord,Show) | 342 | deriving (Eq,Ord,Show) |
510 | 343 | ||
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 | |||
456 | case m of | 456 | case m of |
457 | Nothing -> return $ Right pass | 457 | Nothing -> return $ Right pass |
458 | Just od -> return $ Left (msg, od) | 458 | Just od -> return $ Left (msg, od) |
459 | parse ((_,OnionPacketResponse msg@(OnionToRouteResponse asym)), nodeA) = | 459 | parse ((_,OnionPacketResponse msg@(OnionToRouteResponse asym)), nodeA) = do |
460 | -- dput XOnion $ "TCP data-to-route response from " ++ show (UDP.key2id $ senderKey asym) | ||
460 | return $ | 461 | return $ |
461 | let Right ni = UDP.nodeInfo (UDP.key2id $ senderKey asym) nullAddress4 | 462 | let Right ni = UDP.nodeInfo (UDP.key2id $ senderKey asym) nullAddress4 |
462 | -- -- We have this information, but currently, we're discarding it... | 463 | -- -- 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 :: | |||
48 | toxTransport crypto orouter closeLookup addr udp relaynet _ tcp2client = do | 48 | toxTransport crypto orouter closeLookup addr udp relaynet _ tcp2client = do |
49 | (netcrypto, udp0) <- partitionTransport parseCrypto encodeCrypto udp | 49 | (netcrypto, udp0) <- partitionTransport parseCrypto encodeCrypto udp |
50 | (dhtUDP,udp1) <- partitionTransportM (parseDHTAddr (pendingCookiesUDP crypto) nodeInfo) | 50 | (dhtUDP,udp1) <- partitionTransportM (parseDHTAddr (pendingCookiesUDP crypto) nodeInfo) |
51 | (fmap Just . encodeDHTAddr nodeAddr) | 51 | (fmap Just . encodeDHTAddr nodeAddr) |
52 | $ forwardOnions crypto addr udp0 tcp2client | 52 | $ forwardOnions crypto addr udp0 tcp2client |
53 | -- rlynet0 = layerTransportM (DHT.decrypt crypto Multi.relayNodeId) (DHT.encrypt crypto Multi.relayNodeId) relaynet | 53 | -- rlynet0 = layerTransportM (DHT.decrypt crypto Multi.relayNodeId) (DHT.encrypt crypto Multi.relayNodeId) relaynet |
54 | (dhtTCP,relaynet0) <- partitionTransportM | 54 | (netcryptoTCP, relaynet0) <- partitionTransport parseCrypto encodeCrypto relaynet |
55 | (dhtTCP,relaynet1) <- partitionTransportM | ||
55 | (parseDHTAddr (pendingCookiesTCP crypto) (\nid viarelay -> Right viarelay)) | 56 | (parseDHTAddr (pendingCookiesTCP crypto) (\nid viarelay -> Right viarelay)) |
56 | (fmap Just . encodeDHTAddr id) | 57 | (fmap Just . encodeDHTAddr id) |
57 | relaynet | 58 | relaynet0 |
58 | let _ = dhtTCP :: Transport String ViaRelay (DHTMessage Encrypted8) | 59 | let _ = dhtTCP :: Transport String ViaRelay (DHTMessage Encrypted8) |
59 | dht <- mergeTransports $ DMap.fromList | 60 | dht <- mergeTransports $ DMap.fromList |
60 | [ Multi.UDP :=> ByAddress dhtUDP | 61 | [ Multi.UDP :=> ByAddress dhtUDP |
@@ -65,7 +66,6 @@ toxTransport crypto orouter closeLookup addr udp relaynet _ tcp2client = do | |||
65 | (encodeOnionAddr crypto $ lookupRoute orouter) | 66 | (encodeOnionAddr crypto $ lookupRoute orouter) |
66 | udp1 | 67 | udp1 |
67 | (dta,onion) <- partitionTransportM (parseDataToRoute crypto) (encodeDataToRoute crypto) onion1 | 68 | (dta,onion) <- partitionTransportM (parseDataToRoute crypto) (encodeDataToRoute crypto) onion1 |
68 | (netcryptoTCP, relaynet1) <- partitionTransport parseCrypto encodeCrypto relaynet0 | ||
69 | multi_netcrypto <- mergeTransports $ DMap.fromList | 69 | multi_netcrypto <- mergeTransports $ DMap.fromList |
70 | [ Multi.SessionUDP :=> ByAddress netcrypto | 70 | [ Multi.SessionUDP :=> ByAddress netcrypto |
71 | , Multi.SessionTCP :=> ByAddress netcryptoTCP ] | 71 | , Multi.SessionTCP :=> ByAddress netcryptoTCP ] |