summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Network/Tox/Crypto/Handlers.hs27
1 files changed, 13 insertions, 14 deletions
diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs
index f4b79272..cca8b899 100644
--- a/src/Network/Tox/Crypto/Handlers.hs
+++ b/src/Network/Tox/Crypto/Handlers.hs
@@ -48,7 +48,7 @@ data NetCryptoSessionStatus = Unaccepted | Accepted | Confirmed
48 48
49 49
50type IOHook addr x = addr -> x -> IO (Maybe (x -> x)) 50type IOHook addr x = addr -> x -> IO (Maybe (x -> x))
51type NetCryptoHook = IOHook NetCryptoSession CryptoData 51type NetCryptoHook = IOHook NetCryptoSession CryptoMessage
52type MsgTypeArray = A.UArray Word8 Word64 52type MsgTypeArray = A.UArray Word8 Word64
53-- type MsgOutMap = RangeMap STArray Word8 STRef 53-- type MsgOutMap = RangeMap STArray Word8 STRef
54-- type MsgOutMap = W64.Word64Map Word8 54-- type MsgOutMap = W64.Word64Map Word8
@@ -367,7 +367,7 @@ freshCryptoSession sessions
367 labelThread tid ("NetCryptoDequeue." ++ show (key2id remotePublicKey)) 367 labelThread tid ("NetCryptoDequeue." ++ show (key2id remotePublicKey))
368 fix $ \loop -> do 368 fix $ \loop -> do
369 cd <- atomically $ PQ.dequeue pktq 369 cd <- atomically $ PQ.dequeue pktq
370 _ <- runCryptoHook (netCryptoSession0 {ncDequeueThread=Just tid}) cd 370 _ <- runCryptoHook (netCryptoSession0 {ncDequeueThread=Just tid}) (bufferData cd)
371 loop 371 loop
372 -- launch dequeueOutgoing thread 372 -- launch dequeueOutgoing thread
373 threadidOutgoing <- forkIO $ do 373 threadidOutgoing <- forkIO $ do
@@ -525,7 +525,7 @@ cryptoNetHandler sessions addr (NetCrypto (CryptoPacket nonce16 encrypted)) = do
525 isLossy _ = False 525 isLossy _ = False
526 if isLossy msgTypMapped 526 if isLossy msgTypMapped
527 then do atomically $ PQ.observeOutOfBand ncPacketQueue bufferEnd 527 then do atomically $ PQ.observeOutOfBand ncPacketQueue bufferEnd
528 runCryptoHook session cd 528 runCryptoHook session (bufferData cd)
529 else do atomically $ PQ.enqueue ncPacketQueue bufferEnd cd 529 else do atomically $ PQ.enqueue ncPacketQueue bufferEnd cd
530 return Nothing 530 return Nothing
531 where 531 where
@@ -535,15 +535,14 @@ cryptoNetHandler sessions addr (NetCrypto (CryptoPacket nonce16 encrypted)) = do
535 _ -> error "unreachable-last2Bytes" 535 _ -> error "unreachable-last2Bytes"
536 dATA_NUM_THRESHOLD = 21845 -- = 65535 / 3 536 dATA_NUM_THRESHOLD = 21845 -- = 65535 / 3
537 537
538-- | TODO: make this accept CrytpoMessage instead 538runCryptoHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (x -> x))
539runCryptoHook :: NetCryptoSession -> CryptoData -> IO (Maybe (x -> x))
540runCryptoHook session@(NCrypto {ncState, ncHooks,ncSessionSecret,ncTheirSessionPublic,ncTheirBaseNonce,ncIncomingTypeArray}) 539runCryptoHook session@(NCrypto {ncState, ncHooks,ncSessionSecret,ncTheirSessionPublic,ncTheirBaseNonce,ncIncomingTypeArray})
541 cd@(CryptoData {bufferStart, bufferEnd, bufferData=cm}) = do 540 cm {-cd@(CryptoData {bufferStart, bufferEnd, bufferData=cm})-} = do
542 hookmap <- atomically $ readTVar ncHooks 541 hookmap <- atomically $ readTVar ncHooks
543 -- run hook 542 -- run hook
544 flip fix (cd,hookmap) $ \lookupAgain (cd,hookmap) -> do 543 flip fix (cm,hookmap) $ \lookupAgain (cm,hookmap) -> do
545 msgTypes <- atomically $ readTVar ncIncomingTypeArray 544 msgTypes <- atomically $ readTVar ncIncomingTypeArray
546 let msgTyp = cd ^. messageType 545 let msgTyp = cm ^. messageType
547 msgTypMapped64 = msgTypes A.! fromEnum8 (msgID cm) 546 msgTypMapped64 = msgTypes A.! fromEnum8 (msgID cm)
548 msgTypMapped = fromWord64 $ msgTypMapped64 547 msgTypMapped = fromWord64 $ msgTypMapped64
549 if msgTypMapped64 == 0 548 if msgTypMapped64 == 0
@@ -552,19 +551,19 @@ runCryptoHook session@(NCrypto {ncState, ncHooks,ncSessionSecret,ncTheirSessionP
552 case Map.lookup msgTypMapped hookmap of 551 case Map.lookup msgTypMapped hookmap of
553 Nothing -> do -- no recognizing hook, run ncUnrecognizedHook0, loopAgain on result 552 Nothing -> do -- no recognizing hook, run ncUnrecognizedHook0, loopAgain on result
554 unrecognize <- atomically $ readTVar (ncUnrecognizedHook session) 553 unrecognize <- atomically $ readTVar (ncUnrecognizedHook session)
555 mbConsume <- unrecognize msgTypMapped session cd 554 mbConsume <- unrecognize msgTypMapped session cm
556 case mbConsume of 555 case mbConsume of
557 Just f -> do 556 Just f -> do
558 -- ncUnrecognizedHook0 may have updated the hookmap 557 -- ncUnrecognizedHook0 may have updated the hookmap
559 hookmap' <- atomically $ readTVar ncHooks 558 hookmap' <- atomically $ readTVar ncHooks
560 lookupAgain (f cd,hookmap') 559 lookupAgain (f cm,hookmap')
561 Nothing -> return Nothing 560 Nothing -> return Nothing
562 Just hooks -> flip fix (hooks,cd,msgTypMapped) $ \loop (hooks,cd,typ) -> do 561 Just hooks -> flip fix (hooks,cm,msgTypMapped) $ \loop (hooks,cm,typ) -> do
563 let _ = cd :: CryptoData 562 let _ = cm :: CryptoMessage
564 case (hooks,cd) of 563 case (hooks,cm) of
565 ([],_) -> return Nothing 564 ([],_) -> return Nothing
566 (hook:more,cd) -> do 565 (hook:more,cd) -> do
567 r <- hook session cd :: IO (Maybe (CryptoData -> CryptoData)) 566 r <- hook session cm :: IO (Maybe (CryptoMessage -> CryptoMessage))
568 case r of 567 case r of
569 Just f -> let newcd = f cd 568 Just f -> let newcd = f cd
570 newtyp = newcd ^. messageType 569 newtyp = newcd ^. messageType