Refactor, and bitflags in binary message type

2 files changed, 78 insertions, 38 deletions

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
diff --git a/src/Network/Tox/Crypto/Transport.hs b/src/Network/Tox/Crypto/Transport.hs
index 35b4904e..21100c86 100644
--- a/src/Network/Tox/Crypto/Transport.hs
+++ b/src/Network/Tox/Crypto/Transport.hs
@@ -48,6 +48,9 @@ module Network.Tox.Crypto.Transport
     , isIndirectGrpChat
     , LossyOrLossless(..)
     , lossyness
+    , fromEnum8
+    , fromEnum16
+    , toEnum8
     ) where
 
 import Crypto.Tox
@@ -61,6 +64,7 @@ import Data.ByteString as B
 import Data.Maybe
 import Data.Monoid
 import Data.Word
+import Data.Bits
 import Crypto.Hash
 import Control.Lens
 import Data.Text as T
@@ -418,14 +422,23 @@ class AsWord16 a where
 
 toEnum8 ::Enum a => Word8 -> a
 toEnum8 = toEnum . fromIntegral
+fromEnum8 :: Enum a => a -> Word8
+fromEnum8 = fromIntegral . fromEnum
+
 fromEnum16 :: Enum a => a -> Word16
 fromEnum16 = fromIntegral . fromEnum
 
+
+-- MessageType, for our client keep it inside 16 bits
+-- but we should extend it to 32 or even 64 on the wire.
+-- Bits: 000000glxxxxxxxx, x = message id or extension specific, l = if extended, lossy/lossless, g = if extended, nongroup/group
+--      (at least one bit set in high byte means extended, if none but the g flag and possibly l flag, assume default grp extension)
 instance AsWord16 MessageType where
     toWord16 (Msg msgID) = fromIntegral (fromIntegral (fromEnum16 msgID) :: Word8)
-    toWord16 (GrpMsg lsy msgName) = 256 * (fromEnum16 lsy + 1) + fromIntegral (fromIntegral (fromEnum msgName) :: Word8)
-    fromWord16 x | x < 256 = Msg (toEnum $ fromIntegral x)
-    fromWord16 x           = GrpMsg (toEnum8 ((fromIntegral (x `div` 256)) - 1)) (toEnum8 (fromIntegral x :: Word8))
+    toWord16 (GrpMsg lsy msgName) = 512 + 256 * (fromEnum16 lsy) + fromIntegral (fromIntegral (fromEnum msgName) :: Word8)
+    fromWord16 x | x < 256                          = Msg (toEnum $ fromIntegral x)
+    fromWord16 x | x < 1024, x .|. 0x0200 == 0x0200 = GrpMsg (toEnum8 (fromIntegral ((x - 512) `div` 256))) (toEnum8 (fromIntegral x :: Word8))
+    fromWord16 x = error "Not clear how to convert Word16 to MessageType"
 
 word16 :: (Functor f, AsWord16 x) => (Word16 -> f Word16) -> (x -> f x)
 word16  = lens toWord16 (\_ x -> fromWord16 x)