summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Data/PacketQueue.hs17
-rw-r--r--src/Network/Tox/Crypto/Handlers.hs48
2 files changed, 38 insertions, 27 deletions
diff --git a/src/Data/PacketQueue.hs b/src/Data/PacketQueue.hs
index 59b41d91..82b6f8f0 100644
--- a/src/Data/PacketQueue.hs
+++ b/src/Data/PacketQueue.hs
@@ -208,8 +208,15 @@ newOutGoing inq towire toWireIO num capacity seqstart = do
208 , pktoToWire = towire 208 , pktoToWire = towire
209 } 209 }
210 210
211data OutGoingResult = OGSuccess | OGFull | OGEncodeFail 211data OutGoingResult a = OGSuccess a | OGFull | OGEncodeFail
212 deriving (Eq,Show) 212 deriving (Show)
213
214instance Eq (OutGoingResult a) where
215 OGSuccess _ == OGSuccess _ = True
216 OGFull == OGFull = True
217 OGEncodeFail == OGEncodeFail = True
218 _ == _ = False
219
213 220
214-- | do something in IO before appending to the queue 221-- | do something in IO before appending to the queue
215readyOutGoing :: PacketOutQueue extra msg wire fromwire -> IO (STM extra) 222readyOutGoing :: PacketOutQueue extra msg wire fromwire -> IO (STM extra)
@@ -265,7 +272,7 @@ peekPacket getExtra q@(PacketOutQueue { pktoInPQ, pktoOutPQ, pktoPacketNo, pktoT
265-- | Convert a message to packet format and append it to the front of a queue 272-- | Convert a message to packet format and append it to the front of a queue
266-- used for outgoing messages. (Note that ‘front‛ usually means the higher 273-- used for outgoing messages. (Note that ‘front‛ usually means the higher
267-- index in this implementation.) 274-- index in this implementation.)
268tryAppendQueueOutgoing :: STM extra -> PacketOutQueue extra msg wire fromwire -> msg -> STM OutGoingResult 275tryAppendQueueOutgoing :: STM extra -> PacketOutQueue extra msg wire fromwire -> msg -> STM (OutGoingResult wire)
269tryAppendQueueOutgoing getExtra q@(PacketOutQueue { pktoInPQ, pktoOutPQ, pktoPacketNo, pktoToWireIO, pktoToWire }) msg 276tryAppendQueueOutgoing getExtra q@(PacketOutQueue { pktoInPQ, pktoOutPQ, pktoPacketNo, pktoToWireIO, pktoToWire }) msg
270 = do 277 = do
271 be <- readTVar (buffend pktoOutPQ) 278 be <- readTVar (buffend pktoOutPQ)
@@ -288,7 +295,7 @@ tryAppendQueueOutgoing getExtra q@(PacketOutQueue { pktoInPQ, pktoOutPQ, pktoPac
288 modifyTVar' (buffend pktoOutPQ) (+1) 295 modifyTVar' (buffend pktoOutPQ) (+1)
289 writeTVar pktoPacketNo $! pktno' 296 writeTVar pktoPacketNo $! pktno'
290 writeArray (pktq pktoOutPQ) i (Just (pktno,pkt)) 297 writeArray (pktq pktoOutPQ) i (Just (pktno,pkt))
291 return OGSuccess 298 return (OGSuccess pkt)
292 -- queue is full 299 -- queue is full
293 Just (n,_) -> do 300 Just (n,_) -> do
294 nn <- getHighestHandledPacketPlus1 q 301 nn <- getHighestHandledPacketPlus1 q
@@ -298,7 +305,7 @@ tryAppendQueueOutgoing getExtra q@(PacketOutQueue { pktoInPQ, pktoOutPQ, pktoPac
298 modifyTVar' (buffend pktoOutPQ) (+1) 305 modifyTVar' (buffend pktoOutPQ) (+1)
299 writeTVar pktoPacketNo $! pktno' 306 writeTVar pktoPacketNo $! pktno'
300 writeArray (pktq pktoOutPQ) i (Just (pktno,pkt)) 307 writeArray (pktq pktoOutPQ) i (Just (pktno,pkt))
301 return OGSuccess 308 return (OGSuccess pkt)
302 -- uh oh this packet is still needed... 309 -- uh oh this packet is still needed...
303 else return OGFull 310 else return OGFull
304 -- don't know how to send this message 311 -- don't know how to send this message
diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs
index 7a7567cf..73e5f686 100644
--- a/src/Network/Tox/Crypto/Handlers.hs
+++ b/src/Network/Tox/Crypto/Handlers.hs
@@ -796,7 +796,7 @@ runUponHandshake netCryptoSession0 addr pktoq = do
796 seqno <- PQ.getLastDequeuedPlus1 pktq 796 seqno <- PQ.getLastDequeuedPlus1 pktq
797 ogresult <- PQ.tryAppendQueueOutgoing getOutGoingParam pktoq (createRequestPacket seqno nums) 797 ogresult <- PQ.tryAppendQueueOutgoing getOutGoingParam pktoq (createRequestPacket seqno nums)
798 case ogresult of 798 case ogresult of
799 PQ.OGSuccess -> return () 799 PQ.OGSuccess _ -> return ()
800 _ -> retry 800 _ -> retry
801 loop 801 loop
802 dput XNetCrypto $ "runUponHandshake: " ++ show threadid ++ " = NetCryptoRequest." ++ show (key2id remotePublicKey) ++ sidStr 802 dput XNetCrypto $ "runUponHandshake: " ++ show threadid ++ " = NetCryptoRequest." ++ show (key2id remotePublicKey) ++ sidStr
@@ -851,13 +851,6 @@ runUponHandshake netCryptoSession0 addr pktoq = do
851 dput XNetCrypto $ "runUponHandshake: Announcing new session" 851 dput XNetCrypto $ "runUponHandshake: Announcing new session"
852 hooks <- atomically $ readTVar (announceNewSessionHooks sessions) 852 hooks <- atomically $ readTVar (announceNewSessionHooks sessions)
853 sendOnline crypto netCryptoSession 853 sendOnline crypto netCryptoSession
854 -- in case ONLINE packet is dropped, send anohter after delay
855 forkIO $ do
856 tid <- myThreadId
857 labelThread tid ("Second Online." ++ show (key2id remotePublicKey) ++ sidStr)
858 threadDelay 1000
859 _ <- sendOnline crypto netCryptoSession
860 return ()
861 -- Run new session hooks 854 -- Run new session hooks
862 flip fix (hooks,netCryptoSession) $ \loop (hooks,session) -> 855 flip fix (hooks,netCryptoSession) $ \loop (hooks,session) ->
863 case hooks of 856 case hooks of
@@ -1228,7 +1221,7 @@ allMsgTypes fDefault = A.listArray (minBound,maxBound) (0:knownMsgs)
1228 , map (const 0) [ 200 .. 255 ] -- All lossy, exept the last 1221 , map (const 0) [ 200 .. 255 ] -- All lossy, exept the last
1229 ] 1222 ]
1230 1223
1231sendCrypto :: TransportCrypto -> NetCryptoSession -> (STM ()) -> CryptoMessage -> IO (Either String ()) 1224sendCrypto :: TransportCrypto -> NetCryptoSession -> (STM ()) -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
1232sendCrypto crypto session updateLocal cm = do 1225sendCrypto crypto session updateLocal cm = do
1233 HaveHandshake outq <- atomically $ readTVar (ncOutgoingQueue session) 1226 HaveHandshake outq <- atomically $ readTVar (ncOutgoingQueue session)
1234 -- XXX: potential race? if shared secret comes out of sync with cache? 1227 -- XXX: potential race? if shared secret comes out of sync with cache?
@@ -1238,30 +1231,40 @@ sendCrypto crypto session updateLocal cm = do
1238 atomically $ do 1231 atomically $ do
1239 result <- PQ.tryAppendQueueOutgoing getOutGoingParam outq cm 1232 result <- PQ.tryAppendQueueOutgoing getOutGoingParam outq cm
1240 case result of 1233 case result of
1241 PQ.OGSuccess -> updateLocal >> return (Right()) 1234 PQ.OGSuccess x -> updateLocal >> return (Right x)
1242 PQ.OGFull -> return (Left "Outgoing packet buffer is full") 1235 PQ.OGFull -> return (Left "Outgoing packet buffer is full")
1243 PQ.OGEncodeFail -> return (Left "Failed to encode outgoing packet") 1236 PQ.OGEncodeFail -> return (Left "Failed to encode outgoing packet")
1244 1237
1245sendPing :: TransportCrypto -> NetCryptoSession -> IO (Either String ()) 1238sendPing :: TransportCrypto -> NetCryptoSession -> IO (Either String (CryptoPacket Encrypted))
1246sendPing crypto session = do 1239sendPing crypto session = do
1247 let cm=OneByte PING 1240 let cm=OneByte PING
1248 addMsgToLastN False (cm ^. messageType) session (Out cm) 1241 addMsgToLastN False (cm ^. messageType) session (Out cm)
1249 sendCrypto crypto session (return ()) (OneByte PING) 1242 sendCrypto crypto session (return ()) (OneByte PING)
1250 1243
1251sendOnline :: TransportCrypto -> NetCryptoSession -> IO (Either String ()) 1244sendOnline :: TransportCrypto -> NetCryptoSession -> IO (Either String (CryptoPacket Encrypted))
1252sendOnline crypto session = do 1245sendOnline crypto session = do
1253 let cm=OneByte ONLINE 1246 let cm=OneByte ONLINE
1254 addMsgToLastN False (cm ^. messageType) session (Out cm) 1247 addMsgToLastN False (cm ^. messageType) session (Out cm)
1255 sendCrypto crypto session (return ()) (OneByte ONLINE) 1248 result <- sendCrypto crypto session (return ()) (OneByte ONLINE)
1256 1249 -- double this packet
1257sendOffline :: TransportCrypto -> NetCryptoSession -> IO (Either String ()) 1250 case result of
1251 Right pkt -> do
1252 void . forkIO $ do
1253 tid <- myThreadId
1254 labelThread tid "TEMPORARY.PACKET.DOUBLE.ONLINE"
1255 threadDelay 100000 -- delay 10th of a second
1256 case ncSockAddr session of
1257 HaveDHTKey saddr -> sendSessionPacket (ncAllSessions session) saddr pkt
1258 return (Right pkt)
1259
1260sendOffline :: TransportCrypto -> NetCryptoSession -> IO (Either String (CryptoPacket Encrypted))
1258sendOffline crypto session = do 1261sendOffline crypto session = do
1259 let cm=OneByte OFFLINE 1262 let cm=OneByte OFFLINE
1260 addMsgToLastN False (cm ^. messageType) session (Out cm) 1263 addMsgToLastN False (cm ^. messageType) session (Out cm)
1261 sendCrypto crypto session (return ()) (OneByte OFFLINE) 1264 sendCrypto crypto session (return ()) (OneByte OFFLINE)
1262 1265
1263 1266
1264sendKill :: TransportCrypto -> NetCryptoSession -> IO (Either String ()) 1267sendKill :: TransportCrypto -> NetCryptoSession -> IO (Either String (CryptoPacket Encrypted))
1265sendKill crypto session = do 1268sendKill crypto session = do
1266 let cm=OneByte KillPacket 1269 let cm=OneByte KillPacket
1267 mbOutQ <- atomically $ readTVar (ncOutgoingQueue session) 1270 mbOutQ <- atomically $ readTVar (ncOutgoingQueue session)
@@ -1294,9 +1297,10 @@ sendKill crypto session = do
1294 HaveDHTKey saddr -> do 1297 HaveDHTKey saddr -> do
1295 sendSessionPacket (ncAllSessions session) saddr pkt 1298 sendSessionPacket (ncAllSessions session) saddr pkt
1296 dput XNetCrypto $ "sent kill packet (sessionid: " ++ show (ncSessionId session) ++ ")... now destroying session..." 1299 dput XNetCrypto $ "sent kill packet (sessionid: " ++ show (ncSessionId session) ++ ")... now destroying session..."
1297 Right <$> destroySession session 1300 destroySession session
1301 return (Right pkt)
1298 1302
1299setNick :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String ()) 1303setNick :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String (CryptoPacket Encrypted))
1300setNick crypto session nick = do 1304setNick crypto session nick = do
1301 let Just (_,maxlen) = msgSizeParam NICKNAME 1305 let Just (_,maxlen) = msgSizeParam NICKNAME
1302 if B.length nick > maxlen 1306 if B.length nick > maxlen
@@ -1310,7 +1314,7 @@ setNick crypto session nick = do
1310 addMsgToLastN False (cm ^. messageType) session (Out cm) 1314 addMsgToLastN False (cm ^. messageType) session (Out cm)
1311 sendCrypto crypto session updateLocal cm 1315 sendCrypto crypto session updateLocal cm
1312 1316
1313setTyping :: TransportCrypto -> NetCryptoSession -> TypingStatus -> IO (Either String ()) 1317setTyping :: TransportCrypto -> NetCryptoSession -> TypingStatus -> IO (Either String (CryptoPacket Encrypted))
1314setTyping crypto session status = do 1318setTyping crypto session status = do
1315 let updateLocal = do 1319 let updateLocal = do
1316 view <- readTVar (ncView session) 1320 view <- readTVar (ncView session)
@@ -1327,7 +1331,7 @@ setNoSpam crypto session mbnospam = do
1327 writeTVar (svNoSpam view) mbnospam 1331 writeTVar (svNoSpam view) mbnospam
1328 return (Right ()) 1332 return (Right ())
1329 1333
1330setStatus :: TransportCrypto -> NetCryptoSession -> UserStatus -> IO (Either String ()) 1334setStatus :: TransportCrypto -> NetCryptoSession -> UserStatus -> IO (Either String (CryptoPacket Encrypted))
1331setStatus crypto session status = do 1335setStatus crypto session status = do
1332 let updateLocal = do 1336 let updateLocal = do
1333 view <- readTVar (ncView session) 1337 view <- readTVar (ncView session)
@@ -1336,7 +1340,7 @@ setStatus crypto session status = do
1336 addMsgToLastN False (cm ^. messageType) session (Out cm) 1340 addMsgToLastN False (cm ^. messageType) session (Out cm)
1337 sendCrypto crypto session updateLocal cm 1341 sendCrypto crypto session updateLocal cm
1338 1342
1339setStatusMsg :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String ()) 1343setStatusMsg :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String (CryptoPacket Encrypted))
1340setStatusMsg crypto session msg = do 1344setStatusMsg crypto session msg = do
1341 let Just (_,maxlen) = msgSizeParam STATUSMESSAGE 1345 let Just (_,maxlen) = msgSizeParam STATUSMESSAGE
1342 if B.length msg > maxlen 1346 if B.length msg > maxlen
@@ -1349,7 +1353,7 @@ setStatusMsg crypto session msg = do
1349 addMsgToLastN False (cm ^. messageType) session (Out cm) 1353 addMsgToLastN False (cm ^. messageType) session (Out cm)
1350 sendCrypto crypto session updateLocal cm 1354 sendCrypto crypto session updateLocal cm
1351 1355
1352sendChatMsg :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String ()) 1356sendChatMsg :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String (CryptoPacket Encrypted))
1353sendChatMsg crypto session msg = do 1357sendChatMsg crypto session msg = do
1354 let Just (_,maxlen) = msgSizeParam MESSAGE 1358 let Just (_,maxlen) = msgSizeParam MESSAGE
1355 if B.length msg > maxlen 1359 if B.length msg > maxlen