diff options
-rw-r--r-- | src/Network/Tox/Crypto/Handlers.hs | 27 |
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 | ||
50 | type IOHook addr x = addr -> x -> IO (Maybe (x -> x)) | 50 | type IOHook addr x = addr -> x -> IO (Maybe (x -> x)) |
51 | type NetCryptoHook = IOHook NetCryptoSession CryptoData | 51 | type NetCryptoHook = IOHook NetCryptoSession CryptoMessage |
52 | type MsgTypeArray = A.UArray Word8 Word64 | 52 | type 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 | 538 | runCryptoHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (x -> x)) |
539 | runCryptoHook :: NetCryptoSession -> CryptoData -> IO (Maybe (x -> x)) | ||
540 | runCryptoHook session@(NCrypto {ncState, ncHooks,ncSessionSecret,ncTheirSessionPublic,ncTheirBaseNonce,ncIncomingTypeArray}) | 539 | runCryptoHook 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 |