summaryrefslogtreecommitdiff
path: root/dht/src
diff options
context:
space:
mode:
Diffstat (limited to 'dht/src')
-rw-r--r--dht/src/Network/QueryResponse.hs32
-rw-r--r--dht/src/Network/Tox/Onion/Transport.hs36
-rw-r--r--dht/src/Network/Tox/Transport.hs6
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.
53data Arrival err addr x 53data 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))
157partitionTransport parse encodex tr = 157partitionTransport parse encodex tr =
158 partitionTransportM (return . parse) (return . encodex) tr 158 partitionTransportM (return . parse) (return . encodex) tr
159 159
160
161partitionAndForkTransport ::
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)
167partitionAndForkTransport 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(..))
58import Network.Tox.NodeId 58import Network.Tox.NodeId
59import Network.QueryResponse 59import Network.QueryResponse
60 60
61{-
62encodeOnionAddr :: TransportCrypto 61encodeOnionAddr :: 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-}
67encodeOnionAddr :: TransportCrypto
68 -> (NodeInfo -> RouteId -> IO (Maybe OnionRoute))
69 -> (OnionMessage Encrypted, OnionDestination RouteId)
70 -> IO (Maybe
71 (Either (TCP.RelayPacket, TCP.NodeInfo) (ByteString, SockAddr)))
72encodeOnionAddr crypto _ (msg,OnionToOwner ni p) = 65encodeOnionAddr 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 )
75encodeOnionAddr crypto getRoute (msg,OnionDestination x ni Nothing) = do 68encodeOnionAddr 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
79encodeOnionAddr crypto getRoute (msg,OnionDestination _ ni (Just rid)) = do 70encodeOnionAddr 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)
91wrapForRoute :: TransportCrypto 78wrapForRoute :: 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)
96wrapForRoute crypto msg ni r@OnionRoute{routeRelayPort=Nothing} = 83wrapForRoute 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 }
107wrapForRoute 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
111wrapIndirectHops :: TransportCrypto 95wrapIndirectHops :: 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))
48toxTransport crypto orouter closeLookup addr udp relaynet tcp2server tcp2client = do 48toxTransport 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