diff options
Diffstat (limited to 'src/Network/Tox/AggregateSession.hs')
-rw-r--r-- | src/Network/Tox/AggregateSession.hs | 21 |
1 files changed, 11 insertions, 10 deletions
diff --git a/src/Network/Tox/AggregateSession.hs b/src/Network/Tox/AggregateSession.hs index df16dc4e..8c728660 100644 --- a/src/Network/Tox/AggregateSession.hs +++ b/src/Network/Tox/AggregateSession.hs | |||
@@ -2,6 +2,7 @@ | |||
2 | -- single online/offline presence. This allows multiple lossless links to the | 2 | -- single online/offline presence. This allows multiple lossless links to the |
3 | -- same identity at different addresses, or even to the same address. | 3 | -- same identity at different addresses, or even to the same address. |
4 | {-# LANGUAGE CPP #-} | 4 | {-# LANGUAGE CPP #-} |
5 | {-# LANGUAGE GADTs #-} | ||
5 | {-# LANGUAGE LambdaCase #-} | 6 | {-# LANGUAGE LambdaCase #-} |
6 | {-# LANGUAGE PatternSynonyms #-} | 7 | {-# LANGUAGE PatternSynonyms #-} |
7 | module Network.Tox.AggregateSession | 8 | module Network.Tox.AggregateSession |
@@ -23,6 +24,7 @@ module Network.Tox.AggregateSession | |||
23 | import Control.Concurrent.STM | 24 | import Control.Concurrent.STM |
24 | import Control.Concurrent.STM.TMChan | 25 | import Control.Concurrent.STM.TMChan |
25 | import Control.Monad | 26 | import Control.Monad |
27 | import Data.Dependent.Sum | ||
26 | import Data.Function | 28 | import Data.Function |
27 | import qualified Data.IntMap.Strict as IntMap | 29 | import qualified Data.IntMap.Strict as IntMap |
28 | ;import Data.IntMap.Strict (IntMap) | 30 | ;import Data.IntMap.Strict (IntMap) |
@@ -39,13 +41,12 @@ import GHC.Conc (labelThread) | |||
39 | 41 | ||
40 | import Connection (Status (..)) | 42 | import Connection (Status (..)) |
41 | import Crypto.Tox (PublicKey, toPublic) | 43 | import Crypto.Tox (PublicKey, toPublic) |
44 | import Data.Tox.Msg | ||
42 | import Data.Wrapper.PSQInt as PSQ | 45 | import Data.Wrapper.PSQInt as PSQ |
43 | import DPut | 46 | import DPut |
44 | import DebugTag | 47 | import DebugTag |
45 | import Network.QueryResponse | 48 | import Network.QueryResponse |
46 | import Network.Tox.Crypto.Transport (CryptoMessage (..), pattern KillPacket, | 49 | import Network.Tox.Crypto.Transport |
47 | pattern ONLINE, pattern PING, | ||
48 | pattern PacketRequest) | ||
49 | import Network.Tox.DHT.Transport (key2id) | 50 | import Network.Tox.DHT.Transport (key2id) |
50 | import Network.Tox.NodeId (ToxProgress (..)) | 51 | import Network.Tox.NodeId (ToxProgress (..)) |
51 | import Network.Tox.Session | 52 | import Network.Tox.Session |
@@ -122,17 +123,17 @@ keepAlive s q = do | |||
122 | , take 8 $ show $ key2id $ sTheirUserKey s | 123 | , take 8 $ show $ key2id $ sTheirUserKey s |
123 | , show $ sSessionID s]) | 124 | , show $ sSessionID s]) |
124 | 125 | ||
125 | let outPrint e = dput XNetCrypto $ shows (sSessionID s,sTheirAddr s) $ " <-- " ++ e | 126 | let -- outPrint e = dput XNetCrypto $ shows (sSessionID s,sTheirAddr s) $ " <-- " ++ e |
126 | unexpected e = dput XUnexpected $ shows (sSessionID s,sTheirAddr s) $ " <-- " ++ e | 127 | unexpected e = dput XUnexpected $ shows (sSessionID s,sTheirAddr s) $ " <-- " ++ e |
127 | 128 | ||
128 | doAlive = do | 129 | doAlive = do |
129 | -- outPrint $ "Beacon" | 130 | -- outPrint $ "Beacon" |
130 | sendMessage (sTransport s) () (OneByte PING) | 131 | sendMessage (sTransport s) () (Pkt ALIVE ==> ()) |
131 | 132 | ||
132 | doRequestMissing = do | 133 | doRequestMissing = do |
133 | (ns,nmin) <- sMissingInbound s | 134 | (ns,nmin) <- sMissingInbound s |
134 | -- outPrint $ "PacketRequest " ++ show (nmin,ns) | 135 | -- outPrint $ "PacketRequest " ++ show (nmin,ns) |
135 | sendMessage (sTransport s) () (RequestResend PacketRequest ns) | 136 | sendMessage (sTransport s) () (Pkt PacketRequest ==> MissingPackets ns) |
136 | `catchIOError` \e -> do | 137 | `catchIOError` \e -> do |
137 | unexpected $ "PacketRequest " ++ take 200 (show (nmin,length ns,ns)) | 138 | unexpected $ "PacketRequest " ++ take 200 (show (nmin,length ns,ns)) |
138 | unexpected $ "PacketRequest: " ++ show e | 139 | unexpected $ "PacketRequest: " ++ show e |
@@ -195,7 +196,7 @@ forkSession c s setStatus = forkIO $ do | |||
195 | 196 | ||
196 | atomically $ setStatus $ InProgress AwaitingSessionPacket | 197 | atomically $ setStatus $ InProgress AwaitingSessionPacket |
197 | awaitPacket $ \_ (online,()) -> do | 198 | awaitPacket $ \_ (online,()) -> do |
198 | when (msgID online /= ONLINE) $ do | 199 | when (msgID online /= M ONLINE) $ do |
199 | inPrint $ "Unexpected initial packet: " ++ show (msgID online) | 200 | inPrint $ "Unexpected initial packet: " ++ show (msgID online) |
200 | atomically $ do setStatus Established | 201 | atomically $ do setStatus Established |
201 | sendPacket online | 202 | sendPacket online |
@@ -204,9 +205,9 @@ forkSession c s setStatus = forkIO $ do | |||
204 | awaitPacket $ \awaitNext (x,()) -> do | 205 | awaitPacket $ \awaitNext (x,()) -> do |
205 | bump | 206 | bump |
206 | case msgID x of | 207 | case msgID x of |
207 | PING -> return () | 208 | M ALIVE -> return () |
208 | KillPacket -> sClose s | 209 | M KillPacket -> sClose s |
209 | _ -> atomically $ sendPacket x | 210 | _ -> atomically $ sendPacket x |
210 | awaitNext | 211 | awaitNext |
211 | atomically $ setStatus Dormant | 212 | atomically $ setStatus Dormant |
212 | killThread beacon | 213 | killThread beacon |