From f0821a9484c3d65167a82e4d40fff72bc9b62312 Mon Sep 17 00:00:00 2001 From: Debian Live user Date: Mon, 30 Oct 2017 00:41:27 +0000 Subject: messageType lens --- src/Network/Tox/Crypto/Transport.hs | 85 +++++++++++++++++++++++++++++-------- 1 file changed, 68 insertions(+), 17 deletions(-) (limited to 'src/Network/Tox/Crypto/Transport.hs') 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 -- cgit v1.2.3