diff options
-rw-r--r-- | dht/src/Network/QueryResponse.hs | 32 | ||||
-rw-r--r-- | dht/src/Network/Tox/Onion/Transport.hs | 36 | ||||
-rw-r--r-- | dht/src/Network/Tox/Transport.hs | 6 |
3 files changed, 14 insertions, 60 deletions
diff --git a/dht/src/Network/QueryResponse.hs b/dht/src/Network/QueryResponse.hs index 1bfa995f..89723da2 100644 --- a/dht/src/Network/QueryResponse.hs +++ b/dht/src/Network/QueryResponse.hs | |||
@@ -52,7 +52,7 @@ import Data.TableMethods | |||
52 | -- | An inbound packet or condition raised while monitoring a connection. | 52 | -- | An inbound packet or condition raised while monitoring a connection. |
53 | data Arrival err addr x | 53 | data Arrival err addr x |
54 | = Terminated -- ^ Virtual message that signals EOF. | 54 | = Terminated -- ^ Virtual message that signals EOF. |
55 | | ParseError !err -- ^ A badly-formed message was recieved. | 55 | | ParseError !err -- ^ A badly-formed message was received. |
56 | | Arrival { arrivedFrom :: !addr , arrivedMsg :: !x } -- ^ Inbound message. | 56 | | Arrival { arrivedFrom :: !addr , arrivedMsg :: !x } -- ^ Inbound message. |
57 | 57 | ||
58 | -- | Three methods are required to implement a datagram based query\/response protocol. | 58 | -- | Three methods are required to implement a datagram based query\/response protocol. |
@@ -157,36 +157,6 @@ partitionTransport :: ((b,a) -> Either (x,xaddr) (b,a)) | |||
157 | partitionTransport parse encodex tr = | 157 | partitionTransport parse encodex tr = |
158 | partitionTransportM (return . parse) (return . encodex) tr | 158 | partitionTransportM (return . parse) (return . encodex) tr |
159 | 159 | ||
160 | |||
161 | partitionAndForkTransport :: | ||
162 | (dst -> msg -> IO ()) | ||
163 | -> ((b,a) -> IO (Either (x,xaddr) (b,a))) | ||
164 | -> ((x,xaddr) -> IO (Maybe (Either (msg,dst) (b,a)))) | ||
165 | -> Transport err a b | ||
166 | -> IO (Transport err xaddr x, Transport err a b) | ||
167 | partitionAndForkTransport forkedSend parse encodex tr = do | ||
168 | tchan <- atomically newTChan | ||
169 | let xtr = tr { awaitMessage = \kont -> fix $ \again -> do | ||
170 | awaitMessage tr $ \case | ||
171 | Arrival a b -> parse (b,a) >>= \case | ||
172 | Left (x,xaddr) -> kont $ Arrival xaddr x | ||
173 | Right (b,a) -> atomically (writeTChan tchan (Arrival a b)) >> join (atomically again) | ||
174 | ParseError e -> kont $ ParseError e | ||
175 | Terminated -> atomically (writeTChan tchan Terminated) >> kont Terminated | ||
176 | , sendMessage = \addr' msg' -> do | ||
177 | msg_addr <- encodex (msg',addr') | ||
178 | case msg_addr of | ||
179 | Just (Right (b,a)) -> sendMessage tr a b | ||
180 | Just (Left (msg,dst)) -> forkedSend dst msg | ||
181 | Nothing -> return () | ||
182 | } | ||
183 | ytr = Transport | ||
184 | { awaitMessage = \kont -> readTChan tchan >>= pure . kont | ||
185 | , sendMessage = sendMessage tr | ||
186 | , setActive = \_ -> return () | ||
187 | } | ||
188 | return (xtr, ytr) | ||
189 | |||
190 | -- | | 160 | -- | |
191 | -- * f add x --> Nothing, consume x | 161 | -- * f add x --> Nothing, consume x |
192 | -- --> Just id, leave x to a different handler | 162 | -- --> Just id, leave x to a different handler |
diff --git a/dht/src/Network/Tox/Onion/Transport.hs b/dht/src/Network/Tox/Onion/Transport.hs index 913d339d..6319ed2f 100644 --- a/dht/src/Network/Tox/Onion/Transport.hs +++ b/dht/src/Network/Tox/Onion/Transport.hs | |||
@@ -58,55 +58,39 @@ import Network.Tox.DHT.Transport (SendNodes(..)) | |||
58 | import Network.Tox.NodeId | 58 | import Network.Tox.NodeId |
59 | import Network.QueryResponse | 59 | import Network.QueryResponse |
60 | 60 | ||
61 | {- | ||
62 | encodeOnionAddr :: TransportCrypto | 61 | encodeOnionAddr :: TransportCrypto |
63 | -> (NodeInfo -> RouteId -> IO (Maybe OnionRoute)) | 62 | -> (NodeInfo -> RouteId -> IO (Maybe OnionRoute)) |
64 | -> (OnionMessage Encrypted,OnionDestination RouteId) | 63 | -> (OnionMessage Encrypted,OnionDestination RouteId) |
65 | -> IO (Maybe (ByteString, SockAddr)) | 64 | -> IO (Maybe (ByteString, SockAddr)) |
66 | -} | ||
67 | encodeOnionAddr :: TransportCrypto | ||
68 | -> (NodeInfo -> RouteId -> IO (Maybe OnionRoute)) | ||
69 | -> (OnionMessage Encrypted, OnionDestination RouteId) | ||
70 | -> IO (Maybe | ||
71 | (Either (TCP.RelayPacket, TCP.NodeInfo) (ByteString, SockAddr))) | ||
72 | encodeOnionAddr crypto _ (msg,OnionToOwner ni p) = | 65 | encodeOnionAddr crypto _ (msg,OnionToOwner ni p) = |
73 | return $ Just $ Right ( runPut $ putResponse (OnionResponse p msg) | 66 | return $ Just ( runPut $ putResponse (OnionResponse p msg) |
74 | , nodeAddr ni ) | 67 | , nodeAddr ni ) |
75 | encodeOnionAddr crypto getRoute (msg,OnionDestination x ni Nothing) = do | 68 | encodeOnionAddr crypto getRoute (msg,OnionDestination x ni Nothing) = do |
76 | encodeOnionAddr crypto getRoute (msg,OnionDestination x ni (Just $ routeId $ nodeId ni) ) | 69 | encodeOnionAddr crypto getRoute (msg,OnionDestination x ni (Just $ routeId $ nodeId ni) ) |
77 | -- dput XMisc $ "ONION encode missing routeid" | ||
78 | -- return Nothing | ||
79 | encodeOnionAddr crypto getRoute (msg,OnionDestination _ ni (Just rid)) = do | 70 | encodeOnionAddr crypto getRoute (msg,OnionDestination _ ni (Just rid)) = do |
80 | let go route = do | 71 | let go route = do |
81 | mreq <- wrapForRoute crypto msg ni route | 72 | req <- wrapForRoute crypto msg ni route |
82 | case mreq of | 73 | return ( runPut $ putRequest req , nodeAddr $ routeNodeA route) |
83 | Right req -> return $ Right ( runPut $ putRequest req , nodeAddr $ routeNodeA route) | ||
84 | Left o | Just port <- routeRelayPort route | ||
85 | -> return $ Left ( o, TCP.NodeInfo (routeNodeA route) port) | ||
86 | m <- {-# SCC "encodeOnionAddr.getRoute" #-} getRoute ni rid | 74 | m <- {-# SCC "encodeOnionAddr.getRoute" #-} getRoute ni rid |
87 | x <- {-# SCC "encodeOnionAddr.wrapForRoute" #-} mapM go m | 75 | x <- {-# SCC "encodeOnionAddr.wrapForRoute" #-} mapM go m |
88 | return x | 76 | return x |
89 | 77 | ||
90 | -- wrapForRoute :: TransportCrypto -> OnionMessage Encrypted -> NodeInfo -> OnionRoute -> IO (OnionRequest N0) | ||
91 | wrapForRoute :: TransportCrypto | 78 | wrapForRoute :: TransportCrypto |
92 | -> OnionMessage Encrypted | 79 | -> OnionMessage Encrypted |
93 | -> NodeInfo | 80 | -> NodeInfo |
94 | -> OnionRoute | 81 | -> OnionRoute |
95 | -> IO (Either TCP.RelayPacket (OnionRequest N0)) | 82 | -> IO (OnionRequest N0) |
96 | wrapForRoute crypto msg ni r@OnionRoute{routeRelayPort=Nothing} = | 83 | wrapForRoute crypto msg ni r = |
97 | wrapIndirectHops crypto msg ni r $ \nonce saddr msg' -> do | 84 | wrapIndirectHops crypto msg ni r $ \nonce saddr msg' -> do |
98 | fwd <- wrapOnion crypto (routeAliasA r) | 85 | fwd <- wrapOnion crypto (routeAliasA r) |
99 | nonce | 86 | nonce |
100 | (id2key . nodeId $ routeNodeA r) | 87 | (id2key . nodeId $ routeNodeA r) |
101 | saddr | 88 | saddr |
102 | msg' | 89 | msg' |
103 | return $ Right OnionRequest { onionNonce = nonce | 90 | return $ OnionRequest { onionNonce = nonce |
104 | , onionForward = fwd | 91 | , onionForward = fwd |
105 | , pathFromOwner = NoReturnPath | 92 | , pathFromOwner = NoReturnPath |
106 | } | 93 | } |
107 | wrapForRoute crypto msg ni r@OnionRoute { routeRelayPort = Just _ } = | ||
108 | wrapIndirectHops crypto msg ni r $ \nonce saddr fwd -> | ||
109 | return $ Left $ TCP.OnionPacket nonce $ Addressed (nodeAddr $ routeNodeB r) fwd | ||
110 | 94 | ||
111 | wrapIndirectHops :: TransportCrypto | 95 | wrapIndirectHops :: TransportCrypto |
112 | -> OnionMessage Encrypted | 96 | -> OnionMessage Encrypted |
diff --git a/dht/src/Network/Tox/Transport.hs b/dht/src/Network/Tox/Transport.hs index 12886245..ff99b747 100644 --- a/dht/src/Network/Tox/Transport.hs +++ b/dht/src/Network/Tox/Transport.hs | |||
@@ -38,14 +38,14 @@ toxTransport :: | |||
38 | -> SockAddr -- ^ UDP bind-address | 38 | -> SockAddr -- ^ UDP bind-address |
39 | -> UDPTransport | 39 | -> UDPTransport |
40 | -> Transport String ViaRelay B.ByteString | 40 | -> Transport String ViaRelay B.ByteString |
41 | -> (TCP.NodeInfo -> RelayPacket -> IO ()) -- ^ TCP server-bound callback. | 41 | -> (TCP.NodeInfo -> RelayPacket -> IO ()) -- ^ (UNUSED) TCP server-bound callback. |
42 | -> (Int -> OnionMessage Encrypted -> IO ()) -- ^ TCP client-bound callback. | 42 | -> (Int -> OnionMessage Encrypted -> IO ()) -- ^ TCP client-bound callback. |
43 | -> IO ( Transport String Multi.SessionAddress (CryptoPacket Encrypted) | 43 | -> IO ( Transport String Multi.SessionAddress (CryptoPacket Encrypted) |
44 | , Transport String Multi.NodeInfo (DHTMessage Encrypted8) | 44 | , Transport String Multi.NodeInfo (DHTMessage Encrypted8) |
45 | , Transport String (OnionDestination RouteId) (OnionMessage Encrypted) | 45 | , Transport String (OnionDestination RouteId) (OnionMessage Encrypted) |
46 | , Transport String AnnouncedRendezvous (PublicKey,OnionData) | 46 | , Transport String AnnouncedRendezvous (PublicKey,OnionData) |
47 | , Transport String Multi.SessionAddress (Handshake Encrypted)) | 47 | , Transport String Multi.SessionAddress (Handshake Encrypted)) |
48 | toxTransport crypto orouter closeLookup addr udp relaynet tcp2server 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) |
@@ -60,7 +60,7 @@ toxTransport crypto orouter closeLookup addr udp relaynet tcp2server tcp2client | |||
60 | [ Multi.UDP :=> ByAddress dhtUDP | 60 | [ Multi.UDP :=> ByAddress dhtUDP |
61 | , Multi.TCP :=> ByAddress dhtTCP | 61 | , Multi.TCP :=> ByAddress dhtTCP |
62 | ] | 62 | ] |
63 | (onion1,udp2) <- partitionAndForkTransport tcp2server | 63 | (onion1,udp2) <- partitionTransportM |
64 | (parseOnionAddr $ lookupSender orouter) | 64 | (parseOnionAddr $ lookupSender orouter) |
65 | (encodeOnionAddr crypto $ lookupRoute orouter) | 65 | (encodeOnionAddr crypto $ lookupRoute orouter) |
66 | udp1 | 66 | udp1 |