hooks to keep SessionView up to date

2 files changed, 97 insertions, 5 deletions

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.
diff --git a/src/Network/Tox/Crypto/Transport.hs b/src/Network/Tox/Crypto/Transport.hs
index 70405a3e..40288502 100644
--- a/src/Network/Tox/Crypto/Transport.hs
+++ b/src/Network/Tox/Crypto/Transport.hs
@@ -53,6 +53,7 @@ module Network.Tox.Crypto.Transport
     , fromEnum8
     , fromEnum16
     , toEnum8
+    , msgSizeParam
     ) where
 
 import Crypto.Tox