summaryrefslogtreecommitdiff
path: root/src/Network/Tox/AggregateSession.hs
diff options
context:
space:
mode:
authorJoe Crayne <joe@jerkface.net>2018-11-17 03:09:48 -0500
committerJoe Crayne <joe@jerkface.net>2018-12-16 14:08:26 -0500
commitc1d01920220bcab32b5a77c0b25e65518e8d90d4 (patch)
treeff5cd9038867c121eda89229440e881eca132fa3 /src/Network/Tox/AggregateSession.hs
parent18dd982102ad8cb46c75897cec10483621f38dfc (diff)
dependent-sum based CryptoMessage.
Diffstat (limited to 'src/Network/Tox/AggregateSession.hs')
-rw-r--r--src/Network/Tox/AggregateSession.hs21
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 #-}
7module Network.Tox.AggregateSession 8module Network.Tox.AggregateSession
@@ -23,6 +24,7 @@ module Network.Tox.AggregateSession
23import Control.Concurrent.STM 24import Control.Concurrent.STM
24import Control.Concurrent.STM.TMChan 25import Control.Concurrent.STM.TMChan
25import Control.Monad 26import Control.Monad
27import Data.Dependent.Sum
26import Data.Function 28import Data.Function
27import qualified Data.IntMap.Strict as IntMap 29import 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
40import Connection (Status (..)) 42import Connection (Status (..))
41import Crypto.Tox (PublicKey, toPublic) 43import Crypto.Tox (PublicKey, toPublic)
44import Data.Tox.Msg
42import Data.Wrapper.PSQInt as PSQ 45import Data.Wrapper.PSQInt as PSQ
43import DPut 46import DPut
44import DebugTag 47import DebugTag
45import Network.QueryResponse 48import Network.QueryResponse
46import Network.Tox.Crypto.Transport (CryptoMessage (..), pattern KillPacket, 49import Network.Tox.Crypto.Transport
47 pattern ONLINE, pattern PING,
48 pattern PacketRequest)
49import Network.Tox.DHT.Transport (key2id) 50import Network.Tox.DHT.Transport (key2id)
50import Network.Tox.NodeId (ToxProgress (..)) 51import Network.Tox.NodeId (ToxProgress (..))
51import Network.Tox.Session 52import 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