diff options
Diffstat (limited to 'dht/src/Network/Tox/AggregateSession.hs')
-rw-r--r-- | dht/src/Network/Tox/AggregateSession.hs | 41 |
1 files changed, 28 insertions, 13 deletions
diff --git a/dht/src/Network/Tox/AggregateSession.hs b/dht/src/Network/Tox/AggregateSession.hs index 33b1fafb..44bbf9b9 100644 --- a/dht/src/Network/Tox/AggregateSession.hs +++ b/dht/src/Network/Tox/AggregateSession.hs | |||
@@ -28,6 +28,7 @@ import Control.Exception | |||
28 | import Control.Monad | 28 | import Control.Monad |
29 | import Data.Dependent.Sum | 29 | import Data.Dependent.Sum |
30 | import Data.Function | 30 | import Data.Function |
31 | import Data.Functor | ||
31 | import qualified Data.IntMap.Strict as IntMap | 32 | import qualified Data.IntMap.Strict as IntMap |
32 | ;import Data.IntMap.Strict (IntMap) | 33 | ;import Data.IntMap.Strict (IntMap) |
33 | import Data.List | 34 | import Data.List |
@@ -219,6 +220,9 @@ forkSession c s setStatus = forkIO $ do | |||
219 | atomically $ setStatus Dormant | 220 | atomically $ setStatus Dormant |
220 | killThread beacon | 221 | killThread beacon |
221 | 222 | ||
223 | sessionIsPreferredTo :: Session -> Session -> Bool | ||
224 | sessionIsPreferredTo s t = True -- TODO: Check address types. | ||
225 | |||
222 | -- | Add a new session (in 'AwaitingSessionPacket' state) to the | 226 | -- | Add a new session (in 'AwaitingSessionPacket' state) to the |
223 | -- 'AggregateSession'. If the supplied session is not compatible because it is | 227 | -- 'AggregateSession'. If the supplied session is not compatible because it is |
224 | -- between the wrong ToxIDs or because the AggregateSession is closed, | 228 | -- between the wrong ToxIDs or because the AggregateSession is closed, |
@@ -229,25 +233,35 @@ forkSession c s setStatus = forkIO $ do | |||
229 | -- one active session). | 233 | -- one active session). |
230 | addSession :: AggregateSession -> Session -> IO AddResult | 234 | addSession :: AggregateSession -> Session -> IO AddResult |
231 | addSession c s = do | 235 | addSession c s = do |
232 | (result,mcon,rejected) <- atomically $ do | 236 | (result,mcon,rejected,closed) <- atomically $ do |
233 | let them = sTheirUserKey s | 237 | let them = sTheirUserKey s |
234 | me = toPublic $ sOurKey s | 238 | me = toPublic $ sOurKey s |
235 | compat <- checkCompatible me them c | 239 | result <- checkCompatible me them c <&> \case |
236 | let result = case compat of | ||
237 | Nothing -> FirstSession | 240 | Nothing -> FirstSession |
238 | Just True -> AddedSession | 241 | Just True -> AddedSession |
239 | Just False -> RejectedSession | 242 | Just False -> RejectedSession |
240 | case result of | 243 | case result of |
241 | RejectedSession -> return (result,Nothing,Just s) | 244 | RejectedSession -> return (result,Nothing,Just s,Nothing) |
242 | _ -> do | 245 | _ -> do |
243 | statvar <- newTVar Dormant | 246 | statvar <- newTVar Dormant |
244 | imap <- readTVar (contactSession c) | 247 | imap <- readTVar (contactSession c) |
245 | let con = SingleCon s statvar | 248 | let nodekey = sTheirDHTKey s |
246 | s0 = IntMap.lookup (sSessionID s) imap | 249 | ts = [ t | SingleCon t _ <- IntMap.elems imap, nodekey == sTheirDHTKey t ] |
247 | imap' = IntMap.insert (sSessionID s) con imap | 250 | case ts of |
248 | writeTVar (contactSession c) imap' | 251 | [] -> do |
249 | return (result,Just con,singleSession <$> s0) | 252 | let con = SingleCon s statvar |
250 | 253 | s0 = IntMap.lookup (sSessionID s) imap | |
254 | imap' = IntMap.insert (sSessionID s) con imap | ||
255 | writeTVar (contactSession c) imap' | ||
256 | return (result,Just con,singleSession <$> s0, Nothing) | ||
257 | (t:_) | s `sessionIsPreferredTo` t -> do | ||
258 | let con = SingleCon s statvar | ||
259 | s0 = IntMap.lookup (sSessionID s) imap | ||
260 | imap' = IntMap.insert (sSessionID s) con imap | ||
261 | writeTVar (contactSession c) imap' | ||
262 | return (result,Just con,singleSession <$> s0, Just (sSessionID t)) | ||
263 | (t:_) -> do | ||
264 | error "TODO: Prefer older session (udp over tcp for example)" | ||
251 | mapM_ sClose rejected | 265 | mapM_ sClose rejected |
252 | when (isNothing mcon) $ dput XMan "addSession: Rejected session!" | 266 | when (isNothing mcon) $ dput XMan "addSession: Rejected session!" |
253 | forM_ (mcon :: Maybe SingleCon) $ \con -> do | 267 | forM_ (mcon :: Maybe SingleCon) $ \con -> do |
@@ -263,6 +277,7 @@ addSession c s = do | |||
263 | writeTVar (contactEstablished c) emap' | 277 | writeTVar (contactEstablished c) emap' |
264 | status <- aggregateStatus c | 278 | status <- aggregateStatus c |
265 | when (status /= status0) $ notifyState c c s status | 279 | when (status /= status0) $ notifyState c c s status |
280 | mapM_ (delSession c) closed | ||
266 | 281 | ||
267 | return result | 282 | return result |
268 | 283 | ||