1 files changed, 68 insertions, 17 deletions

diff --git a/src/Network/Tox/Crypto/Transport.hs b/src/Network/Tox/Crypto/Transport.hs
index f7fd0f7e..4b2e97ce 100644
--- a/src/Network/Tox/Crypto/Transport.hs
+++ b/src/Network/Tox/Crypto/Transport.hs
@@ -10,6 +10,7 @@ module Network.Tox.Crypto.Transport
     , NetCrypto(..)
     , CryptoData(..)
     , CryptoMessage(..)
+    , MessageName(..)
     , CryptoPacket(..)
     , HandshakeData(..)
     , Handshake(..)
@@ -18,6 +19,7 @@ module Network.Tox.Crypto.Transport
     , UserStatus(..)
     , TypingStatus(..)
     , GroupChatId(..)
+    , MessageType(..)
     -- feild name classes
     , HasGroupChatID(..)
     , HasGroupNumber(..)
@@ -25,10 +27,14 @@ module Network.Tox.Crypto.Transport
     , HasMessageNumber(..)
     , HasMessageName(..)
     , HasMessageData(..)
+    , HasName(..)
+    , HasTitle(..)
+    , HasMessage(..)
+    , HasMessageType(..)
     -- lenses
     , userStatus, nick, statusMessage, typingStatus, message, action, groupChatID
     , groupNumber, groupNumberToJoin, peerNumber, messageNumber
-    , messageName, messageData
+    , messageName, messageData, name, title, message, messageType
     -- constructor
     , msg
     , leaveMsg
@@ -36,6 +42,7 @@ module Network.Tox.Crypto.Transport
     -- utils
     , sizedN
     , sizedAtLeastN
+    , isIndirectGrpChat
     ) where
 
 import Crypto.Tox
@@ -192,14 +199,6 @@ statusMessage = lens getter setter
     setter (UpToN STATUSMESSAGE _) nick = UpToN STATUSMESSAGE (T.encodeUtf8 . T.pack $ nick)
     setter _ _                          = erCompat "statusMessage"
 
-message :: Functor f => (String -> f String)-> (CryptoMessage -> f CryptoMessage)
-message = lens getter setter
-  where
-    getter (UpToN MESSAGE bstr) = T.unpack $ T.decodeUtf8 bstr
-    getter _                     = erCompat "message"
-    setter (UpToN MESSAGE _) message = UpToN MESSAGE (T.encodeUtf8 . T.pack $ message)
-    setter _ _                     = erCompat "message"
-
 action :: Functor f => (String -> f String)-> (CryptoMessage -> f CryptoMessage)
 action = lens getter setter
   where
@@ -341,6 +340,7 @@ instance HasMessageNumber CryptoMessage where
 messageNumber :: (Functor f, HasMessageNumber x) => (Word32 -> f Word32) -> (x -> f x)
 messageNumber = lens getMessageNumber setMessageNumber
 
+
 class HasMessageName x where
     getMessageName :: x -> MessageName
     setMessageName :: x -> MessageName -> x
@@ -363,6 +363,36 @@ instance HasMessageName CryptoMessage where
 messageName :: (Functor f, HasMessageName x) => (MessageName -> f MessageName) -> (x -> f x)
 messageName = lens getMessageName setMessageName
 
+data MessageType = Msg MessageID
+                 | GrpMsg MessageName
+    deriving (Eq,Show)
+
+class HasMessageType x where
+    getMessageType :: x -> MessageType
+    setMessageType :: x -> MessageType -> x
+
+instance HasMessageType CryptoMessage where
+    getMessageType (OneByte mid) = Msg mid
+    getMessageType (TwoByte mid _) = Msg mid
+    getMessageType m@(UpToN mid _) | isIndirectGrpChat mid = GrpMsg (getMessageName m)
+    getMessageType (UpToN mid _) = Msg mid
+
+    setMessageType m@(UpToN mid _) (GrpMsg mname) | isIndirectGrpChat mid = setMessageName m mname
+    setMessageType (OneByte _   ) (GrpMsg mname) = setMessageName (UpToN MESSAGE_GROUPCHAT B.empty        ) mname
+    setMessageType (TwoByte  _ x) (GrpMsg mname) = setMessageName (UpToN MESSAGE_GROUPCHAT (B.singleton x)) mname
+    setMessageType (UpToN _ x) (GrpMsg mname) = setMessageName (UpToN MESSAGE_GROUPCHAT x) mname
+    setMessageType m (Msg mid) | Just (True,1) <- msgSizeParam mid = OneByte mid
+    setMessageType (OneByte mid0  ) (Msg mid) | Just (True,2) <- msgSizeParam mid = TwoByte mid 0 
+    setMessageType (TwoByte mid0 x) (Msg mid) | Just (True,2) <- msgSizeParam mid = TwoByte mid x 
+    setMessageType (UpToN mid0 x)   (Msg mid) | Just (True,n) <- msgSizeParam mid = UpToN mid (sizedN n x)
+    setMessageType (OneByte mid0)   (Msg mid) = UpToN mid B.empty
+    setMessageType (TwoByte mid0 x) (Msg mid) = UpToN mid (B.singleton x)
+    setMessageType (UpToN mid0 x)   (Msg mid) = UpToN mid x
+
+-- | This lens should always succeed on CryptoMessage
+messageType :: (Functor f, HasMessageType x) => (MessageType -> f MessageType) -> (x -> f x)
+messageType = lens getMessageType setMessageType
+
 type MessageData = B.ByteString
 
 class HasMessageData x where
@@ -388,17 +418,38 @@ class HasTitle x where
     setTitle :: x -> Text -> x
 
 instance HasTitle CryptoMessage where
-    getTitle (UpToN (fromEnum -> 0x62) (sizedAtLeastN 4 -> B.splitAt 3 -> (_,B.uncons -> Just (0x0a,mdata)))) = decodeUtf8 mdata
+    getTitle (UpToN DIRECT_GROUPCHAT {-Ox62-}    (sizedAtLeastN 4 -> B.splitAt 3 -> (_,B.uncons -> Just (0x0a,mdata)))) = decodeUtf8 mdata
+    getTitle (UpToN xE                           (sizedAtLeastN 4 -> B.splitAt 3 -> (_,B.uncons -> Just (toEnum . fromIntegral -> GroupchatTitleChange,mdata))))
+        | isIndirectGrpChat xE = decodeUtf8 mdata
     getTitle _   = error "getTitle on CryptoMessage without title field."
 
-    -- If its not
-    setTitle (UpToN xE@(fromEnum -> 0x62) (sizedAtLeastN 4 -> B.splitAt 3 -> (bs,B.uncons -> Just (_,xs)))) messagedata -- MESSAGE_GROUPCHAT
+    setTitle (UpToN xE@DIRECT_GROUPCHAT {-0x62-} (sizedAtLeastN 4 -> B.splitAt 3 -> (bs,B.uncons -> Just (_,xs)))) messagedata
         = UpToN xE (B.concat [bs,B.cons 0x0a (encodeUtf8 messagedata)])
+    setTitle (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (bs,B.uncons -> Just (_,xs)))) title
+        | isIndirectGrpChat xE = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum GroupchatTitleChange) (encodeUtf8 title)])
     setTitle _ _ = error "setTitle on CryptoMessage without title field."
 
 title :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x)
 title = lens getTitle setTitle
 
+class HasMessage x where
+    getMessage :: x -> Text
+    setMessage :: x -> Text -> x
+
+instance HasMessage CryptoMessage where
+    getMessage (UpToN MESSAGE bstr) = T.decodeUtf8 bstr
+    getMessage (UpToN xE                           (sizedAtLeastN 9 -> B.splitAt 8 -> (_,B.uncons -> Just (mnameByte,mdata))))
+        | isIndirectGrpChat xE = decodeUtf8 mdata
+    getMessage _   = error "getMessage on CryptoMessage without message field."
+
+    setMessage (UpToN MESSAGE _) message = UpToN MESSAGE (T.encodeUtf8 $ message)
+    setMessage (UpToN xE (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,B.uncons -> Just (mnameByte,xs)))) message
+        | isIndirectGrpChat xE = UpToN xE (B.concat [bs,B.cons (if mnameByte == 0 then 0x40 else mnameByte) (encodeUtf8 message)])
+    setMessage _ _ = error "setMessage on CryptoMessage without message field."
+
+message :: (Functor f, HasMessage x) => (Text -> f Text) -> (x -> f x)
+message = lens getMessage setMessage
+
 class HasName x where
     getName :: x -> Text
     setName :: x -> Text -> x
@@ -406,12 +457,12 @@ class HasName x where
 
 instance HasName CryptoMessage where
     -- Only MESSAGE_GROUPCHAT:NameChange has Name field
-    getName (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (_,B.uncons -> Just (toEnum . fromIntegral -> NameChange,mdata)))) | isGroupChatMsg xE = decodeUtf8 mdata
+    getName (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (_,B.uncons -> Just (toEnum . fromIntegral -> NameChange,mdata)))) | isIndirectGrpChat xE = decodeUtf8 mdata
     getName _   = error "getName on CryptoMessage without name field."
 
     -- If its not NameChange, this setter will set it to NameChange
     setName (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (bs,B.uncons -> Just (_,xs)))) name
-        | isGroupChatMsg xE = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum NameChange) (encodeUtf8 name)])
+        | isIndirectGrpChat xE = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum NameChange) (encodeUtf8 name)])
     setName _ _ = error "setName on CryptoMessage without name field."
 
 name :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x)
@@ -489,9 +540,9 @@ msgSizeParam MESSAGE_GROUPCHAT {-0x63-} = Nothing -- variable
 msgSizeParam LOSSY_GROUPCHAT   {-0xC7-} = Nothing -- variable
 msgSizeParam _ = Nothing
 
-isGroupChatMsg MESSAGE_GROUPCHAT = True
-isGroupChatMsg LOSSY_GROUPCHAT = True
-isGroupChatMsg _ = False
+isIndirectGrpChat MESSAGE_GROUPCHAT = True
+isIndirectGrpChat LOSSY_GROUPCHAT = True
+isIndirectGrpChat _ = False
 
 -- TODO: Flesh this out.
 data MessageID              -- First byte indicates data