setNoSpam, and defaultTypingHook (why not?)

1 files changed, 39 insertions, 3 deletions

diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs
index fe620757..2fb7f2c1 100644
--- a/src/Network/Tox/Crypto/Handlers.hs
+++ b/src/Network/Tox/Crypto/Handlers.hs
@@ -67,10 +67,13 @@ data SessionView = SessionView
         { svNick        :: TVar ByteString
         , svStatus      :: TVar UserStatus
         , svStatusMsg   :: TVar ByteString
+        , svTyping      :: TVar TypingStatus
+        , svNoSpam      :: TVar (Maybe NoSpam)
         , svTheirNick        :: TVar ByteString
         , svTheirStatus      :: TVar UserStatus
         , svTheirStatusMsg   :: TVar ByteString
-        , svNoSpam      :: TVar (Maybe NoSpam)
+        , svTheirTyping      :: TVar TypingStatus
+        , svTheirNoSpam      :: TVar (Maybe NoSpam)
         , svGroups      :: TVar (Map.Map GroupChatId (Set.Set SockAddr))
 
         -- allthough these directories are not visible to others on the net
@@ -197,10 +200,13 @@ newSessionsState crypto unrechook hooks = do
     nick <- atomically $ newTVar B.empty
     status <- atomically $ newTVar Online
     statusmsg <- atomically $ newTVar B.empty
+    typing <- atomically $ newTVar NotTyping
+    nospam <- atomically $ newTVar Nothing
     theirnick <- atomically $ newTVar B.empty
     theirstatus <- atomically $ newTVar Online
     theirstatusmsg <- atomically $ newTVar B.empty
-    nospam <- atomically $ newTVar Nothing
+    theirtyping <- atomically $ newTVar NotTyping
+    theirnospam <- atomically $ newTVar Nothing
     grps <- atomically $ newTVar Map.empty
     pname <- getProgName
     cachedir <- sensibleCacheDirCreateIfMissing pname
@@ -221,10 +227,13 @@ newSessionsState crypto unrechook hooks = do
                             { svNick        = nick
                             , svStatus      = status
                             , svStatusMsg   = statusmsg
+                            , svTyping      = typing
+                            , svNoSpam      = nospam
                             , svTheirNick        = theirnick
                             , svTheirStatus      = theirstatus
                             , svTheirStatusMsg   = theirstatusmsg
-                            , svNoSpam      = nospam
+                            , svTheirTyping      = theirtyping
+                            , svTheirNoSpam      = theirnospam
                             , svGroups      = grps
                             , svCacheDir    = cachedir
                             , svTmpDir      = tmpdir
@@ -675,6 +684,23 @@ setNick crypto session nick = do
         let nickPacket = error "todo"
         return (Left "TODO: sendMessage crypto (NetCrypto nickPacket)")
         -- return (Right ())
+        --
+setTyping :: TransportCrypto -> NetCryptoSession -> TypingStatus -> IO (Either String ())
+setTyping crypto session status = do
+   let viewVar = ncView session
+   atomically $ do
+    view <- readTVar viewVar
+    writeTVar (svTyping view) status
+   let typingPacket = error "todo"
+   return (Left "TODO: sendMessage crypto (NetCrypto typingPacket)")
+
+setNoSpam :: TransportCrypto -> NetCryptoSession -> Maybe NoSpam -> IO (Either String ())
+setNoSpam crypto session mbnospam = do
+   let viewVar = ncView session
+   atomically $ do
+    view <- readTVar viewVar
+    writeTVar (svNoSpam view) mbnospam
+   return (Right ())
 
 setStatus :: TransportCrypto -> NetCryptoSession -> UserStatus -> IO (Either String ())
 setStatus crypto session status = do
@@ -703,6 +729,7 @@ defaultCryptoDataHooks :: Map.Map MessageType [NetCryptoHook]
 defaultCryptoDataHooks
     = Map.fromList
             [ (Msg USERSTATUS,[defaultUserStatusHook])
+            , (Msg TYPING,[defaultTypingHook])
             , (Msg NICKNAME, [defaultNicknameHook])
             , (Msg STATUSMESSAGE, [defaultStatusMsgHook])
             ]
@@ -716,6 +743,15 @@ defaultUserStatusHook session cm@(TwoByte {msgID=USERSTATUS, msgByte=statusByte}
         writeTVar (svTheirStatus view) status
     hookHelper True (Msg USERSTATUS) session cm
 
+defaultTypingHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage))
+defaultTypingHook session cm@(TwoByte {msgID=TYPING, msgByte=statusByte}) = do
+    let status = toEnum8 statusByte
+        viewVar = ncView session
+    atomically $ do
+        view <- readTVar viewVar
+        writeTVar (svTheirStatus view) status
+    hookHelper True (Msg TYPING) session cm
+
 defaultNicknameHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage))
 defaultNicknameHook session cm@(UpToN {msgID=NICKNAME, msgBytes=nick}) = do
     let viewVar = ncView session