summaryrefslogtreecommitdiff
path: root/dht/src
diff options
context:
space:
mode:
Diffstat (limited to 'dht/src')
-rw-r--r--dht/src/Network/Tox/Relay.hs33
1 files changed, 21 insertions, 12 deletions
diff --git a/dht/src/Network/Tox/Relay.hs b/dht/src/Network/Tox/Relay.hs
index 96838688..66ab4b71 100644
--- a/dht/src/Network/Tox/Relay.hs
+++ b/dht/src/Network/Tox/Relay.hs
@@ -24,7 +24,9 @@ import System.Timeout
24import Crypto.Tox 24import Crypto.Tox
25import qualified Data.IntervalSet as IntSet 25import qualified Data.IntervalSet as IntSet
26 ;import Data.IntervalSet (IntSet) 26 ;import Data.IntervalSet (IntSet)
27import Data.Time.Clock.POSIX
27import Data.Tox.Relay 28import Data.Tox.Relay
29import qualified Data.Wrapper.PSQInt as Int
28import Network.Address (getBindAddress) 30import Network.Address (getBindAddress)
29import Network.SocketLike 31import Network.SocketLike
30import Network.StreamServer 32import Network.StreamServer
@@ -47,16 +49,20 @@ hGetSized h = runGet get <$> B.hGet h len -- We treat parse-fail the same as EOF
47 49
48-- This type manages ConId assignments. 50-- This type manages ConId assignments.
49data RelaySession = RelaySession 51data RelaySession = RelaySession
50 { indexPool :: IntSet -- ^ Ints that are either solicited or associated. 52 { indexPool :: IntSet -- ^ Ints are assigned.
51 , solicited :: Map PublicKey Int -- ^ Reserved ids, not yet in associated. 53 , assigned :: Map PublicKey Int -- ^ Assignments
52 , associated :: IntMap ((ConId -> RelayPacket) -> IO ()) -- ^ Peers this session is connected to. 54 , associated :: IntMap ((ConId -> RelayPacket) -> IO ()) -- ^ Peers this session is connected to.
55 -- TODO: Timestamp PSQ for reclaiming indices. The Bool will indicate
56 -- whether the index was ever associated.
57 , timestamps :: Int.PSQ (Bool,POSIXTime)
53 } 58 }
54 59
55freshSession :: RelaySession 60freshSession :: RelaySession
56freshSession = RelaySession 61freshSession = RelaySession
57 { indexPool = IntSet.empty 62 { indexPool = IntSet.empty
58 , solicited = Map.empty 63 , assigned = Map.empty
59 , associated = IntMap.empty 64 , associated = IntMap.empty
65 , timestamps = Int.empty
60 } 66 }
61 67
62disconnect :: TVar (Map PublicKey (RelayPacket -> IO (),TVar RelaySession)) 68disconnect :: TVar (Map PublicKey (RelayPacket -> IO (),TVar RelaySession))
@@ -174,31 +180,34 @@ handlePacket :: TVar (Map PublicKey (RelayPacket -> IO (), TVar RelaySession)) -
174handlePacket cons thistcp thisKey crypto sendOnion sendToClient session = \case 180handlePacket cons thistcp thisKey crypto sendOnion sendToClient session = \case
175 RoutingRequest them -> join $ atomically $ do 181 RoutingRequest them -> join $ atomically $ do
176 mySession <- readTVar session 182 mySession <- readTVar session
177 mi <- case Map.lookup them (solicited mySession) of 183 -- TODO: Do we already have an association?
184 mi <- case Map.lookup them (assigned mySession) of
178 Nothing -> fmap join $ forM (IntSet.nearestOutsider 0 (indexPool mySession)) $ \i -> do 185 Nothing -> fmap join $ forM (IntSet.nearestOutsider 0 (indexPool mySession)) $ \i -> do
179 if -120 <= i && i <= 119 186 if -120 <= i && i <= 119
180 then do 187 then do
181 writeTVar session mySession 188 writeTVar session mySession
182 { indexPool = IntSet.insert i (indexPool mySession) 189 { indexPool = IntSet.insert i (indexPool mySession)
183 , solicited = Map.insert them i (solicited mySession) 190 , assigned = Map.insert them i (assigned mySession)
184 } 191 }
185 return $ Just i 192 return $ Just i
186 else return Nothing -- No more slots available. 193 else
194 -- TODO: Attempt to reclaim an assigned but not yet associated connection.
195 return Nothing -- No more slots available.
187 Just i -> return $ Just i 196 Just i -> return $ Just i
188 notifyConnect <- fmap (join . join) $ forM mi $ \i -> do 197 notifyConnect <- fmap (join . join) $ forM mi $ \i -> do
189 mp <- Map.lookup them <$> readTVar cons 198 mp <- Map.lookup them <$> readTVar cons
190 forM mp $ \(sendToThem,peer) -> do 199 forM mp $ \(sendToThem,peer) -> do
191 theirSession <- readTVar peer 200 theirSession <- readTVar peer
192 forM (Map.lookup thisKey $ solicited theirSession) $ \reserved_id -> do 201 forM (Map.lookup thisKey $ assigned theirSession) $ \reserved_id -> do
193 let sendToThem' f = sendToThem $ f $ key2c reserved_id 202 let sendToThem' f = sendToThem $ f $ key2c reserved_id
194 sendToClient' f = sendToClient $ f $ key2c i 203 sendToClient' f = sendToClient $ f $ key2c i
195 writeTVar peer theirSession 204 writeTVar peer theirSession
196 { solicited = Map.delete thisKey (solicited theirSession) 205 { -- assigned = Map.insert thisKey reserved_id (assigned theirSession)
197 , associated = IntMap.insert reserved_id sendToClient' (associated theirSession) 206 associated = IntMap.insert reserved_id sendToClient' (associated theirSession)
198 } 207 }
199 writeTVar session mySession 208 writeTVar session mySession
200 { solicited = Map.delete them (solicited mySession) 209 { -- assigned = Map.insert them i (assigned mySession)
201 , associated = IntMap.insert i sendToThem' (associated mySession) 210 associated = IntMap.insert i sendToThem' (associated mySession)
202 } 211 }
203 return $ do 212 return $ do
204 let showSession n k = "("++ show (key2c n) ++ ")" ++ showKey256 k 213 let showSession n k = "("++ show (key2c n) ++ ")" ++ showKey256 k
@@ -262,7 +271,7 @@ tcpRelay crypto udp_addr sendOnion = do
262 b3389 <- getBindAddress "3389" True 271 b3389 <- getBindAddress "3389" True
263 b33445 <- getBindAddress "33445" True 272 b33445 <- getBindAddress "33445" True
264 bany <- getBindAddress "" True 273 bany <- getBindAddress "" True
265 h <- streamServer ServerConfig 274 h <- forkStreamServer ServerConfig
266 { serverWarn = dput XOnion 275 { serverWarn = dput XOnion
267 , serverSession = relaySession crypto clients cons sendOnion 276 , serverSession = relaySession crypto clients cons sendOnion
268 } 277 }