From 4ce5feb72cdb452d0a6ba9cc326d541b292caedb Mon Sep 17 00:00:00 2001 From: James Crayne Date: Tue, 29 May 2018 08:18:04 +0000 Subject: hooks to keep SessionView up to date --- src/Network/Tox/Crypto/Handlers.hs | 101 +++++++++++++++++++++++++++++++++++-- 1 file changed, 96 insertions(+), 5 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 602b14cc..fe620757 100644 --- a/src/Network/Tox/Crypto/Handlers.hs +++ b/src/Network/Tox/Crypto/Handlers.hs @@ -25,6 +25,7 @@ import qualified Data.PacketQueue as PQ ;import Data.PacketQueue (PacketQueue) import Data.Serialize as S import Data.Word +import Data.Maybe import qualified Data.Word64Map as W64 import Data.Word64RangeMap import qualified Data.Set as Set @@ -66,6 +67,9 @@ data SessionView = SessionView { svNick :: TVar ByteString , svStatus :: TVar UserStatus , svStatusMsg :: TVar ByteString + , svTheirNick :: TVar ByteString + , svTheirStatus :: TVar UserStatus + , svTheirStatusMsg :: TVar ByteString , svNoSpam :: TVar (Maybe NoSpam) , svGroups :: TVar (Map.Map GroupChatId (Set.Set SockAddr)) @@ -193,6 +197,9 @@ newSessionsState crypto unrechook hooks = do nick <- atomically $ newTVar B.empty status <- atomically $ newTVar Online statusmsg <- atomically $ newTVar B.empty + theirnick <- atomically $ newTVar B.empty + theirstatus <- atomically $ newTVar Online + theirstatusmsg <- atomically $ newTVar B.empty nospam <- atomically $ newTVar Nothing grps <- atomically $ newTVar Map.empty pname <- getProgName @@ -214,6 +221,9 @@ newSessionsState crypto unrechook hooks = do { svNick = nick , svStatus = status , svStatusMsg = statusmsg + , svTheirNick = theirnick + , svTheirStatus = theirstatus + , svTheirStatusMsg = theirstatusmsg , svNoSpam = nospam , svGroups = grps , svCacheDir = cachedir @@ -652,28 +662,109 @@ allMsgTypes fDefault = A.listArray (minBound,maxBound) (0:knownMsgs) , map (const 0) [ 200 .. 255 ] -- All lossy, exept the last ] --- | handles nothing +setNick :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String ()) +setNick crypto session nick = do + let Just (_,maxlen) = msgSizeParam NICKNAME + if B.length nick > maxlen + then return (Left $ "nickname must not exceed " ++ show maxlen ++ " bytes.") + else do + let viewVar = ncView session + atomically $ do + view <- readTVar viewVar + writeTVar (svNick view) nick + let nickPacket = error "todo" + return (Left "TODO: sendMessage crypto (NetCrypto nickPacket)") + -- return (Right ()) + +setStatus :: TransportCrypto -> NetCryptoSession -> UserStatus -> IO (Either String ()) +setStatus crypto session status = do + let viewVar = ncView session + atomically $ do + view <- readTVar viewVar + writeTVar (svStatus view) status + let statusPacket = error "todo" + return (Left "TODO: sendMessage crypto (NetCrypto statusPacket)") + +setStatusMsg :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String ()) +setStatusMsg crypto session msg = do + let Just (_,maxlen) = msgSizeParam STATUSMESSAGE + if B.length msg > maxlen + then return (Left $ "status message must not exceed " ++ show maxlen ++ " bytes.") + else do + let viewVar = ncView session + atomically $ do + view <- readTVar viewVar + writeTVar (svStatusMsg view) msg + let statusMsgPacket = error "todo" + return (Left "TODO: sendMessage crypto (NetCrypto statusMsgPacket)") + +-- | handles nothings defaultCryptoDataHooks :: Map.Map MessageType [NetCryptoHook] -defaultCryptoDataHooks = Map.empty +defaultCryptoDataHooks + = Map.fromList + [ (Msg USERSTATUS,[defaultUserStatusHook]) + , (Msg NICKNAME, [defaultNicknameHook]) + , (Msg STATUSMESSAGE, [defaultStatusMsgHook]) + ] + +defaultUserStatusHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage)) +defaultUserStatusHook session cm@(TwoByte {msgID=USERSTATUS, msgByte=statusByte}) = do + let status = toEnum8 statusByte + viewVar = ncView session + atomically $ do + view <- readTVar viewVar + writeTVar (svTheirStatus view) status + hookHelper True (Msg USERSTATUS) session cm + +defaultNicknameHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage)) +defaultNicknameHook session cm@(UpToN {msgID=NICKNAME, msgBytes=nick}) = do + let viewVar = ncView session + atomically $ do + view <- readTVar viewVar + writeTVar (svTheirNick view) nick + hookHelper True (Msg NICKNAME) session cm + +defaultStatusMsgHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage)) +defaultStatusMsgHook session cm@(UpToN {msgID=STATUSMESSAGE, msgBytes=msg}) = do + let viewVar = ncView session + atomically $ do + view <- readTVar viewVar + writeTVar (svTheirStatusMsg view) msg + hookHelper True (Msg STATUSMESSAGE) session cm -- | updates ncLastNMsgs, and sends message to type-0 listeners defaultUnRecHook :: MessageType -> NetCryptoHook -defaultUnRecHook typ session cm | any ($ typ) [isKillPacket, isOFFLINE] = atomically $ do +defaultUnRecHook = hookHelper False + +hookHelper :: Bool -> MessageType -> NetCryptoHook +hookHelper _ typ session cm | any ($ typ) [isKillPacket, isOFFLINE] = atomically $ do tmchans <- map snd . IntMap.elems <$> readTVar (ncListeners session) forM_ tmchans $ \chan -> closeTMChan chan return Nothing -defaultUnRecHook typ session cm = do +hookHelper handledFlg typ session cm = do let msgQ = ncLastNMsgs session msgNumVar = ncMsgNumVar session dropCntVar = ncDropCntVar session atomically $ do num <- readTVar msgNumVar - (wraps,offset) <- PQ.enqueue msgQ num (False,cm) + (wraps,offset) <- PQ.enqueue msgQ num (handledFlg,cm) capacity <- PQ.getCapacity msgQ let dropped = wraps * capacity + offset modifyTVar' msgNumVar (+1) writeTVar dropCntVar dropped + atomically $ do + idtmchans <- IntMap.assocs <$> readTVar (ncListeners session) + mbChans + <- forM idtmchans $ \(id,(typ,chan)) -> do + bClosed <- isClosedTMChan chan + if bClosed + then do + modifyTVar' (ncListeners session) (IntMap.delete id) + return Nothing + else return (if typ==0 then Just chan else Nothing) + forM_ (catMaybes mbChans) $ \chan -> do + writeTMChan chan cm return Nothing -- | use to add a single hook to a specific session. -- cgit v1.2.3