From ae2d321f380d4c3b3d967533693a1499f8d15a13 Mon Sep 17 00:00:00 2001 From: James Crayne Date: Fri, 3 Nov 2017 06:43:23 +0000 Subject: Refactor, and bitflags in binary message type --- src/Network/Tox/Crypto/Handlers.hs | 97 ++++++++++++++++++++++++-------------- 1 file changed, 62 insertions(+), 35 deletions(-) (limited to 'src/Network/Tox/Crypto/Handlers.hs') diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs index 0cb2d4db..d6f2de7e 100644 --- a/src/Network/Tox/Crypto/Handlers.hs +++ b/src/Network/Tox/Crypto/Handlers.hs @@ -13,6 +13,7 @@ import Control.Applicative import Control.Monad import Data.Time.Clock.POSIX import qualified Data.ByteString as B +import Data.ByteString (ByteString) import Control.Lens import Data.Function import Data.Serialize as S @@ -34,6 +35,21 @@ type IOHook addr x = addr -> x -> IO (Maybe (x -> x)) type NetCryptoHook = IOHook NetCryptoSession CryptoData type MsgTypeArray = A.UArray Word8 Word16 + +-- | Information, that may be made visible in multiple sessions, as well +-- as displayed in some way to the user via mutiple views. +data SessionView = SessionView + { svNick :: TVar ByteString + , svStatus :: TVar UserStatus + , svStatusMsg :: TVar ByteString + , svGroups :: TVar (Map.Map GroupChatId (Set.Set SockAddr)) + , svCacheDir :: FilePath -- ^ directory path used if the session has to use the disk for cache + -- clean up only if space is needed + , svTmpDir :: FilePath -- Once off storage goes here, should clean up quickly + , svConfigDir :: FilePath -- profile related storage, etc, never clean up + } + + data NetCryptoSession = NCrypto { ncState :: TVar NetCryptoSessionStatus , ncTheirBaseNonce :: TVar Nonce24 -- base nonce + packet number , ncMyPacketNonce :: TVar Nonce24 -- base nonce + packet number @@ -54,23 +70,29 @@ data NetCryptoSession = NCrypto { ncState :: TVar NetCryptoSessionStatus , ncAllSessions :: NetCryptoSessions -- ^ may be needed if one net-crypto session -- needs to possibly start another, as is -- the case in group chats - , ncGroups :: TVar (Map.Map GroupChatId (Set.Set SockAddr)) + , ncView :: TVar SessionView } data NetCryptoSessions = NCSessions { netCryptoSessions :: TVar (Map.Map SockAddr NetCryptoSession) , transportCrypto :: TransportCrypto , defaultHooks :: Map.Map MessageType [NetCryptoHook] , defaultUnrecognizedHook :: MessageType -> NetCryptoHook + , sessionView :: SessionView , msgTypeArray :: MsgTypeArray } newSessionsState :: TransportCrypto -> (MessageType -> NetCryptoHook) -> Map.Map MessageType [NetCryptoHook] -> IO NetCryptoSessions newSessionsState crypto unrechook hooks = do x <- atomically $ newTVar Map.empty + nick <- atomically $ newTVar B.empty + status <- atomically $ newTVar Online + statusmsg <- atomically $ newTVar B.empty + grps <- atomically $ newTVar Map.empty return NCSessions { netCryptoSessions = x , transportCrypto = crypto , defaultHooks = hooks , defaultUnrecognizedHook = unrechook + , sessionView = SessionView { svNick = nick, svStatus = status, svStatusMsg = statusmsg, svGroups = grps } , msgTypeArray = allMsgTypes -- todo make this a parameter } @@ -117,8 +139,8 @@ freshCryptoSession sessions newsession <- generateSecretKey ncHooks0 <- atomically $ newTVar (defaultHooks sessions) ncUnrecognizedHook0 <- atomically $ newTVar (defaultUnrecognizedHook sessions) - ncGroups0 <- atomically $ newTVar (Map.empty) ncMessageTypes0 <- atomically $ newTVar (msgTypeArray sessions) + ncView0 <- atomically $ newTVar (sessionView sessions) let netCryptoSession = NCrypto { ncState = ncState0 , ncTheirBaseNonce= ncTheirBaseNonce0 @@ -132,8 +154,8 @@ freshCryptoSession sessions , ncHooks = ncHooks0 , ncUnrecognizedHook = ncUnrecognizedHook0 , ncAllSessions = sessions - , ncGroups = ncGroups0 , ncMessageTypes = ncMessageTypes0 + , ncView = ncView0 } atomically $ modifyTVar allsessions (Map.insert addr netCryptoSession) @@ -247,38 +269,7 @@ cryptoNetHandler sessions addr (NetCrypto (CryptoPacket nonce16 encrypted)) = do writeTVar ncTheirBaseNonce y -- then set session confirmed, atomically $ writeTVar ncState Confirmed - hookmap <- atomically $ readTVar ncHooks - -- run hook - flip fix (cd,hookmap) $ \lookupAgain (cd,hookmap) -> do - msgTyps <- atomically $ readTVar ncMessageTypes - let msgTyp = cd ^. messageType - msgTypMapped16 = msgTypes ! msgId cd - msgTypMapped = fromIntegral msgTypMapped16 - if msgTypMapped16 == 0 - then return id - else - case Map.lookup msgTypMapped hookmap of - Nothing -> do -- no recognizing hook, run ncUnrecognizedHook0, loopAgain on result - unrecognize <- atomically $ readTVar (ncUnrecognizedHook session) - mbConsume <- unrecognize msgTypMapped session cd - case mbConsume of - Just f -> do - -- ncUnrecognizedHook0 may have updated the hookmap - hookmap' <- atomically $ readTVar ncHooks - lookupAgain (f cd,hookmap') - Nothing -> return Nothing - Just hooks -> flip fix (hooks,cd,msgTypMapped) $ \loop (hooks,cd,typ) -> do - let _ = cd :: CryptoData - case (hooks,cd) of - ([],_) -> return Nothing - (hook:more,cd) -> do - r <- hook session cd :: IO (Maybe (CryptoData -> CryptoData)) - case r of - Just f -> let newcd = f cd - newtyp = newcd ^. messageType - in if newtyp == typ then loop (more,newcd,newtyp) - else lookupAgain (newcd,hookmap) - Nothing -> return Nothing -- message consumed + runCryptoHook session cd where last2Bytes :: Nonce24 -> Word last2Bytes (Nonce24 bs) = case S.decode (B.drop 22 bs) of @@ -286,6 +277,42 @@ cryptoNetHandler sessions addr (NetCrypto (CryptoPacket nonce16 encrypted)) = do _ -> error "unreachable-last2Bytes" dATA_NUM_THRESHOLD = 21845 -- = 65535 / 3 +runCryptoHook :: NetCryptoSession -> CryptoData -> IO (Maybe (x -> x)) +runCryptoHook session@(NCrypto {ncState, ncHooks,ncSessionSecret,ncTheirSessionPublic,ncTheirBaseNonce,ncMessageTypes}) + cd@(CryptoData {bufferStart, bufferEnd, bufferData=cm}) = do + hookmap <- atomically $ readTVar ncHooks + -- run hook + flip fix (cd,hookmap) $ \lookupAgain (cd,hookmap) -> do + msgTypes <- atomically $ readTVar ncMessageTypes + let msgTyp = cd ^. messageType + msgTypMapped16 = msgTypes A.! fromEnum8 (msgID cm) + msgTypMapped = fromWord16 $ msgTypMapped16 + if msgTypMapped16 == 0 + then return $ Just id + else + case Map.lookup msgTypMapped hookmap of + Nothing -> do -- no recognizing hook, run ncUnrecognizedHook0, loopAgain on result + unrecognize <- atomically $ readTVar (ncUnrecognizedHook session) + mbConsume <- unrecognize msgTypMapped session cd + case mbConsume of + Just f -> do + -- ncUnrecognizedHook0 may have updated the hookmap + hookmap' <- atomically $ readTVar ncHooks + lookupAgain (f cd,hookmap') + Nothing -> return Nothing + Just hooks -> flip fix (hooks,cd,msgTypMapped) $ \loop (hooks,cd,typ) -> do + let _ = cd :: CryptoData + case (hooks,cd) of + ([],_) -> return Nothing + (hook:more,cd) -> do + r <- hook session cd :: IO (Maybe (CryptoData -> CryptoData)) + case r of + Just f -> let newcd = f cd + newtyp = newcd ^. messageType + in if newtyp == typ then loop (more,newcd,newtyp) + else lookupAgain (newcd,hookmap) + Nothing -> return Nothing -- message consumed + -- | construct a 'MsgTypeArray' for specified types, using their known common positions -- in the MessageId space if they have such a thing. mkMsgTypes :: [MessageType] -> MsgTypeArray -- cgit v1.2.3