diff options
Diffstat (limited to 'dht/src/Network/SessionTransports.hs')
-rw-r--r-- | dht/src/Network/SessionTransports.hs | 12 |
1 files changed, 7 insertions, 5 deletions
diff --git a/dht/src/Network/SessionTransports.hs b/dht/src/Network/SessionTransports.hs index b6d02f36..68233cd4 100644 --- a/dht/src/Network/SessionTransports.hs +++ b/dht/src/Network/SessionTransports.hs | |||
@@ -1,5 +1,6 @@ | |||
1 | {-# LANGUAGE LambdaCase #-} | 1 | {-# LANGUAGE LambdaCase #-} |
2 | {-# LANGUAGE NamedFieldPuns #-} | 2 | {-# LANGUAGE NamedFieldPuns #-} |
3 | {-# LANGUAGE TupleSections #-} | ||
3 | module Network.SessionTransports | 4 | module Network.SessionTransports |
4 | ( Sessions | 5 | ( Sessions |
5 | , initSessions | 6 | , initSessions |
@@ -73,9 +74,9 @@ newSession Sessions{sessionsByAddr,sessionsById,sessionIds,sessionsSendRaw} unwr | |||
73 | return sid | 74 | return sid |
74 | forM msid $ \sid -> do | 75 | forM msid $ \sid -> do |
75 | let tr = Transport | 76 | let tr = Transport |
76 | { awaitMessage = \kont -> do | 77 | { awaitMessage = do |
77 | x <- takeTMVar mvar | 78 | x <- takeTMVar mvar |
78 | return $ kont $! maybe Terminated (uncurry $ flip Arrival) x | 79 | return $ (, return ()) $ maybe Terminated (uncurry $ flip Arrival) x |
79 | , sendMessage = \addr x -> do | 80 | , sendMessage = \addr x -> do |
80 | x' <- unwrap addr x | 81 | x' <- unwrap addr x |
81 | sessionsSendRaw saddr x' | 82 | sessionsSendRaw saddr x' |
@@ -92,8 +93,9 @@ newSession Sessions{sessionsByAddr,sessionsById,sessionIds,sessionsSendRaw} unwr | |||
92 | } | 93 | } |
93 | return (sid,tr) | 94 | return (sid,tr) |
94 | 95 | ||
95 | sessionHandler :: Sessions x -> (Multi.SessionAddress -> x -> IO (Maybe (x -> x))) | 96 | sessionHandler :: Sessions x -> Arrival err Multi.SessionAddress x |
96 | sessionHandler Sessions{sessionsByAddr} = \addr0 x -> do | 97 | -> STM (Arrival err Multi.SessionAddress x, IO ()) |
98 | sessionHandler Sessions{sessionsByAddr} (Arrival addr0 x) = return $ (,) Discarded $ do | ||
97 | let addr = -- Canonical in case of 6-mapped-4 addresses. | 99 | let addr = -- Canonical in case of 6-mapped-4 addresses. |
98 | Multi.canonize addr0 | 100 | Multi.canonize addr0 |
99 | dispatch [] = return () | 101 | dispatch [] = return () |
@@ -101,4 +103,4 @@ sessionHandler Sessions{sessionsByAddr} = \addr0 x -> do | |||
101 | when (not b) $ dispatch fs | 103 | when (not b) $ dispatch fs |
102 | fs <- atomically $ Map.lookup addr <$> readTVar sessionsByAddr | 104 | fs <- atomically $ Map.lookup addr <$> readTVar sessionsByAddr |
103 | mapM_ (dispatch . IntMap.elems) fs | 105 | mapM_ (dispatch . IntMap.elems) fs |
104 | return Nothing -- consume all packets. | 106 | sessionHandler _ m = return (m, return ()) |