{-# LANGUAGE KindSignatures #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} module Network.Tox.Crypto.Transport ( parseCrypto , encodeCrypto , parseHandshakes , encodeHandshakes , CryptoData(..) , CryptoMessage(..) , MessageName(..) , CryptoPacket(..) , HandshakeData(..) , Handshake(..) , PeerInfo(..) , MessageID(..) , UserStatus(..) , TypingStatus(..) , GroupChatId(..) , MessageType(..) , isKillPacket, isOFFLINE , KnownLossyness(..) , AsWord16(..) , AsWord64(..) -- feild name classes , HasGroupChatID(..) , HasGroupNumber(..) , HasPeerNumber(..) , HasMessageNumber(..) , HasMessageName(..) , HasMessageData(..) , HasName(..) , HasTitle(..) , HasMessage(..) , HasMessageType(..) -- lenses , userStatus, nick, statusMessage, typingStatus, action, groupChatID , groupNumber, groupNumberToJoin, peerNumber, messageNumber , messageName, messageData, name, title, message, messageType -- constructor , msg , leaveMsg , peerQueryMsg -- utils , sizedN , sizedAtLeastN , isIndirectGrpChat , LossyOrLossless(..) , lossyness , fromEnum8 , fromEnum16 , toEnum8 , msgSizeParam ) where import Crypto.Tox import Network.Tox.DHT.Transport (Cookie) import Network.Tox.NodeId import Network.Socket import Data.ByteArray 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 import Data.Text.Encoding as T import Data.Serialize as S import Control.Arrow parseCrypto :: (ByteString, SockAddr) -> Either (CryptoPacket Encrypted, SockAddr) (ByteString, SockAddr) parseCrypto ((B.uncons -> Just (0x1b,pkt)),saddr) = either (\_ -> Right (pkt,saddr)) (\x -> Left (x ,saddr)) $ runGet get pkt parseCrypto not_mine = Right not_mine encodeCrypto :: (CryptoPacket Encrypted, SockAddr) -> Maybe (ByteString, SockAddr) encodeCrypto (x,saddr) = Just (B.cons 0x1b (runPut $ put x),saddr) parseHandshakes :: ByteString -> SockAddr -> Either String (Handshake Encrypted, SockAddr) parseHandshakes (B.uncons -> Just (0x1a,pkt)) saddr = left ("parseHandshakes: "++) $ (,saddr) <$> runGet get pkt parseHandshakes bs _ = Left $ "parseHandshakes_: " ++ show (B.unpack $ B.take 1 bs) encodeHandshakes :: Handshake Encrypted -> SockAddr -> (ByteString, SockAddr) encodeHandshakes x saddr = (B.cons 0x1a (runPut $ put x),saddr) data Handshake (f :: * -> *) = Handshake { -- The cookie is a cookie obtained by -- sending a cookie request packet to the peer and getting a cookie -- response packet with a cookie in it. It may also be obtained in the -- handshake packet by a peer receiving a handshake packet (Other -- Cookie). handshakeCookie :: Cookie f -- The nonce is a nonce used to encrypt the encrypted part of the handshake -- packet. , handshakeNonce :: Nonce24 -- The encrypted part of the handshake packet is encrypted with the long -- term user-keys of both peers. , handshakeData :: f HandshakeData } instance Serialize (Handshake Encrypted) where get = Handshake <$> get <*> get <*> get put (Handshake cookie n24 dta) = put cookie >> put n24 >> put dta data HandshakeData = HandshakeData { baseNonce :: Nonce24 -- ^ 24 bytes base nonce, recipient uses this to encrypt packets sent to the one who sent this handshake -- adding one each time, so it can double as something like an approximate packet number , sessionKey :: PublicKey -- ^ session public key of the peer (32 bytes) -- The recipient of the handshake encrypts using this public key when sending CryptoPackets , cookieHash :: Digest SHA512 -- ^ sha512 hash of the entire Cookie sitting outside the encrypted part -- This prevents a replay attack where a new cookie is inserted into -- an old valid handshake packet , otherCookie :: Cookie Encrypted -- ^ Other Cookie (used by the repient to respond to the handshake packet) } instance Sized HandshakeData where size = contramap baseNonce size <> contramap (key2id . sessionKey) size <> ConstSize 64 -- contramap cookieHash size -- missing instance Sized (Digest SHA512) <> contramap otherCookie size instance Serialize HandshakeData where get = HandshakeData <$> get <*> (id2key <$> get) <*> (fromJust . digestFromByteString <$> getBytes 64) <*> get put (HandshakeData n k h c) = do put n put $ key2id k putByteString (convert h) put c data CryptoPacket (f :: * -> *) = CryptoPacket { -- | The last 2 bytes of the nonce used to encrypt 'pktData' pktNonce :: Word16 -- The payload is encrypted with the session key and 'baseNonce' set by -- the receiver in their handshake + packet number (starting at 0, big -- endian math). , pktData :: f CryptoData } instance Sized CryptoData where size = contramap bufferStart size <> contramap bufferEnd size <> contramap bufferData size instance Serialize (CryptoPacket Encrypted) where get = CryptoPacket <$> get <*> get put (CryptoPacket n16 dta) = put n16 >> put dta data CryptoData = CryptoData { -- | [our recvbuffers buffer_start, (highest packet number handled + 1), (big endian)] bufferStart :: Word32 -- | [ uint32_t packet number if lossless -- , sendbuffer buffer_end if lossy , (big endian)] , bufferEnd :: Word32 -- | [data] (TODO See Note [Padding]) , bufferData :: CryptoMessage } {- Note [Padding] TODO: The 'bufferData' field of 'CryptoData' should probably be something like /Padded CryptoMessage/ because c-toxcore strips leading zeros on incoming and pads leading zeros on outgoing packets. After studying c-toxcore (at commit c49a6e7f5bc245a51a3c85cc2c8b7f881c412998), I've determined the following behavior. Incoming: All leading zero bytes are stripped until possibly the whole packet is consumed (in which case it is discarded). This happens at toxcore/net_crypto.c:1366:handle_data_packet_core(). Outgoing: The number of zeros added is: padding_length len = (1373 - len) `mod` 8 where where /len/ is the size of the non-padded CryptoMessage. This happens at toxcore/net_crypto.c:936:send_data_packet_helper() The number 1373 is written in C as MAX_CRYPTO_DATA_SIZE which is defined in terms of the max /NetCrypto/ packet size (1400) minus the minimum possible size of an id-byte (1) and a /CryptoPacket Encrypted/ ( 2 + 4 + 4 + 16 ). One effect of this is that short messages will be padded to at least 5 bytes. -} instance Serialize CryptoData where get = CryptoData <$> get <*> get <*> get put (CryptoData start end dta) = put start >> put end >> put dta -- The 'UserStatus' equivalent in Presence is: -- -- data JabberShow = Offline -- | ExtendedAway -- | Away -- Tox equiv: Away (1) -- | DoNotDisturb -- Tox equiv: Busy (2) -- | Available -- Tox equiv: Online (0) -- | Chatty -- deriving (Show,Enum,Ord,Eq,Read) -- -- The Enum instance on 'UserStatus' is not arbitrary. It corresponds -- to on-the-wire id numbers. data UserStatus = Online | Away | Busy deriving (Show,Read,Eq,Ord,Enum) data TypingStatus = NotTyping | Typing deriving (Show,Read,Eq,Ord,Enum) data CryptoMessage = OneByte { msgID :: MessageID } | TwoByte { msgID :: MessageID, msgByte :: Word8 } | UpToN { msgID :: MessageID, msgBytes :: ByteString } -- length < N deriving (Eq,Show) instance Sized CryptoMessage where size = VarSize $ \case OneByte {} -> 1 TwoByte {} -> 2 UpToN { msgBytes = bs } -> 1 + B.length bs instance Serialize CryptoMessage where get = do i <- get :: Get MessageID n <- remaining case msgSizeParam i of Just (True,0) -> return $ OneByte i Just (True,1) -> TwoByte i <$> get _ -> UpToN i <$> getByteString n put (OneByte i) = putWord8 (fromIntegral . fromEnum $ i) put (TwoByte i b) = do putWord8 (fromIntegral . fromEnum $ i) putWord8 b put (UpToN i x) = do putWord8 (fromIntegral . fromEnum $ i) putByteString x instance Serialize MessageID where get = toEnum . fromIntegral <$> getWord8 put x = putWord8 (fromIntegral . fromEnum $ x) erCompat :: String -> a erCompat lens = error $ "Use of '" ++ lens ++ "' lens on incompatible CryptoMessage type" typingStatus :: Functor f => (UserStatus -> f UserStatus)-> (CryptoMessage -> f CryptoMessage) typingStatus = lens getter setter where getter :: CryptoMessage -> UserStatus getter (TwoByte TYPING status) = toEnum $ fromIntegral status getter _ = erCompat "typingStatus" setter :: CryptoMessage -> UserStatus -> CryptoMessage setter (TwoByte TYPING _) status = TwoByte TYPING (fromIntegral . fromEnum $ status) setter _ _ = erCompat "typingStatus" userStatus :: Functor f => (UserStatus -> f UserStatus)-> (CryptoMessage -> f CryptoMessage) userStatus = lens getter setter where getter (TwoByte USERSTATUS status) = toEnum $ fromIntegral status getter _ = erCompat "userStatus" setter (TwoByte USERSTATUS _) status = TwoByte USERSTATUS (fromIntegral . fromEnum $ status) setter _ _ = erCompat "userStatus" nick :: Functor f => (Text -> f Text)-> (CryptoMessage -> f CryptoMessage) nick = lens getter setter where getter (UpToN NICKNAME bstr) = T.decodeUtf8 bstr getter _ = erCompat "nick" setter (UpToN NICKNAME _) nick = UpToN NICKNAME (T.encodeUtf8 $ nick) setter _ _ = erCompat "nick" statusMessage :: Functor f => (String -> f String)-> (CryptoMessage -> f CryptoMessage) statusMessage = lens getter setter where getter (UpToN STATUSMESSAGE bstr) = T.unpack $ T.decodeUtf8 bstr getter _ = erCompat "statusMessage" setter (UpToN STATUSMESSAGE _) nick = UpToN STATUSMESSAGE (T.encodeUtf8 . T.pack $ nick) setter _ _ = erCompat "statusMessage" action :: Functor f => (String -> f String)-> (CryptoMessage -> f CryptoMessage) action = lens getter setter where getter (UpToN ACTION bstr) = T.unpack $ T.decodeUtf8 bstr getter _ = erCompat "action" setter (UpToN ACTION _) action = UpToN ACTION (T.encodeUtf8 . T.pack $ action) setter _ _ = erCompat "action" newtype GroupChatId = GrpId ByteString -- 33 bytes deriving (Show,Eq) class HasGroupChatID x where getGroupChatID :: x -> GroupChatId setGroupChatID :: x -> GroupChatId -> x sizedN :: Int -> ByteString -> ByteString sizedN n bs = if B.length bs < n then B.append bs (B.replicate (n - B.length bs) 0) else B.take n bs sizedAtLeastN :: Int -> ByteString -> ByteString sizedAtLeastN n bs = if B.length bs < n then B.append bs (B.replicate (n - B.length bs) 0) else bs instance HasGroupChatID CryptoMessage where -- Get getGroupChatID (UpToN INVITE_GROUPCHAT payload) = let (xs,ys) = B.splitAt 1 payload' payload' = sizedN 38 payload in case B.unpack xs of [isResponse] | 0 <- isResponse -> GrpId (B.take 33 $ B.drop 2 ys) -- skip group number [isResponse] | 1 <- isResponse -> GrpId (B.take 33 $ B.drop 4 ys) -- skip two group numbers _ -> GrpId "" -- error "Unexpected value in INVITE_GROUPCHAT message" getGroupChatID (UpToN ONLINE_PACKET payload) = GrpId (B.take 33 $ B.drop 2 (sizedN 35 payload)) getGroupChatID _ = error "getGroupChatID on non-groupchat message." -- Set setGroupChatID msg@(UpToN INVITE_GROUPCHAT payload) (GrpId newid) = let (xs,ys) = B.splitAt 1 payload' payload' = sizedN 38 payload in case B.unpack xs of [isResponse] | 0 <- isResponse -> UpToN INVITE_GROUPCHAT (B.concat [xs, (B.take 2 ys), sizedN 33 newid]) -- keep group number [isResponse] | 1 <- isResponse -> UpToN INVITE_GROUPCHAT (B.concat [xs, (B.take 4 ys), sizedN 33 newid]) -- keep two group numbers _ -> msg -- unexpected condition, leave unchanged setGroupChatID (UpToN ONLINE_PACKET payload) (GrpId newid) = UpToN ONLINE_PACKET (B.concat [B.take 2 payload, sizedN 33 newid]) setGroupChatID _ _= error "setGroupChatID on non-groupchat message." groupChatID :: (Functor f, HasGroupChatID x) => (GroupChatId -> f GroupChatId) -> (x -> f x) groupChatID = lens getGroupChatID setGroupChatID type GroupNumber = Word16 type PeerNumber = Word16 type MessageNumber = Word32 class HasGroupNumber x where getGroupNumber :: x -> GroupNumber setGroupNumber :: x -> GroupNumber -> x instance HasGroupNumber CryptoMessage where getGroupNumber (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (isResp,xs))) -- note isResp should be 0 or 1 = let twobytes = B.take 2 xs Right n = S.decode twobytes in n getGroupNumber (UpToN (fromEnum -> x) (sizedN 2 -> twobytes)) | x >= 0x61 && x <= 0x63 = let Right n = S.decode twobytes in n getGroupNumber (UpToN (fromEnum -> 0xC7) (sizedN 2 -> twobytes)) = let Right n = S.decode twobytes in n getGroupNumber _ = error "getGroupNumber on CryptoMessage without group number field." setGroupNumber (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (isResp,xs))) groupnum = UpToN INVITE_GROUPCHAT (B.cons isResp (B.append (S.encode groupnum) (B.drop 2 xs))) setGroupNumber (UpToN xE@(fromEnum -> x) (sizedAtLeastN 2 -> B.splitAt 2 -> (twobytes,xs))) groupnum | x >= 0x61 && x <= 0x63 = UpToN xE (B.append (S.encode groupnum) xs) | x == 0xC7 = UpToN xE (B.append (S.encode groupnum) xs) setGroupNumber _ _ = error "setGroupNumber on CryptoMessage without group number field." groupNumber :: (Functor f, HasGroupNumber x) => (Word16 -> f Word16) -> (x -> f x) groupNumber = lens getGroupNumber setGroupNumber class HasGroupNumberToJoin x where getGroupNumberToJoin :: x -> GroupNumber setGroupNumberToJoin :: x -> GroupNumber -> x instance HasGroupNumberToJoin CryptoMessage where getGroupNumberToJoin (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (1,xs))) -- only response has to-join = let twobytes = B.take 2 (B.drop 2 xs) -- skip group number (local) Right n = S.decode twobytes in n getGroupNumberToJoin _ = error "getGroupNumberToJoin on CryptoMessage without group number (to join) field." setGroupNumberToJoin (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (1,xs))) groupnum = let (a,b) = B.splitAt 2 xs (twoBytes,c) = B.splitAt 2 b twoBytes' = S.encode groupnum in UpToN INVITE_GROUPCHAT (B.cons 1 (B.concat [a,twoBytes',c])) setGroupNumberToJoin _ _ = error "setGroupNumberToJoin on CryptoMessage without group number (to join) field." groupNumberToJoin :: (Functor f, HasGroupNumberToJoin x) => (GroupNumber -> f GroupNumber) -> (x -> f x) groupNumberToJoin = lens getGroupNumberToJoin setGroupNumberToJoin class HasPeerNumber x where getPeerNumber :: x -> PeerNumber setPeerNumber :: x -> PeerNumber -> x instance HasPeerNumber CryptoMessage where getPeerNumber (UpToN (fromEnum -> 0x63) (sizedN 4 -> B.splitAt 2 -> (grpnum,twobytes))) = let Right n = S.decode twobytes in n getPeerNumber (UpToN (fromEnum -> 0xC7) (sizedN 4 -> B.splitAt 2 -> (grpnum,twobytes))) = let Right n = S.decode twobytes in n getPeerNumber _ = error "getPeerNumber on CryptoMessage without peer number field." setPeerNumber (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 4 -> B.splitAt 2 -> (gnum,xs))) peernum = UpToN xE (B.concat [gnum,S.encode peernum, B.drop 2 xs]) setPeerNumber (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 4 -> B.splitAt 2 -> (gnum,xs))) peernum = UpToN xE (B.concat [gnum,S.encode peernum, B.drop 2 xs]) setPeerNumber _ _ = error "setPeerNumber on CryptoMessage without peer number field." peerNumber :: (Functor f, HasPeerNumber x) => (Word16 -> f Word16) -> (x -> f x) peerNumber = lens getPeerNumber setPeerNumber class HasMessageNumber x where getMessageNumber :: x -> MessageNumber setMessageNumber :: x -> MessageNumber -> x instance HasMessageNumber CryptoMessage where getMessageNumber (UpToN (fromEnum -> 0x63) (sizedN 8 -> B.splitAt 4 -> (_,fourbytes))) = let Right n = S.decode fourbytes in n getMessageNumber (UpToN (fromEnum -> 0xC7) (sizedN 8 -> B.splitAt 4 -> (_,fourbytes))) = let Right n = S.decode fourbytes in n getMessageNumber _ = error "getMessageNumber on CryptoMessage without message number field." setMessageNumber (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 8 -> B.splitAt 4 -> (bs,xs))) messagenum = UpToN xE (B.concat [bs,S.encode messagenum, B.drop 4 xs]) setMessageNumber (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 8 -> B.splitAt 4 -> (bs,xs))) messagenum = UpToN xE (B.concat [bs,S.encode messagenum, B.drop 4 xs]) setMessageNumber _ _ = error "setMessageNumber on CryptoMessage without message number field." 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 instance HasMessageName CryptoMessage where getMessageName (UpToN (fromEnum -> 0x63) (sizedN 9 -> B.splitAt 8 -> (_,onebyte))) = let [n] = B.unpack onebyte in toEnum . fromIntegral $ n getMessageName (UpToN (fromEnum -> 0xC7) (sizedN 9 -> B.splitAt 8 -> (_,onebyte))) = let [n] = B.unpack onebyte in toEnum . fromIntegral $ n getMessageName _ = error "getMessageName on CryptoMessage without message name field." setMessageName (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,xs))) messagename = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum messagename) (B.drop 1 xs)]) setMessageName (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,xs))) messagename = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum messagename) (B.drop 1 xs)]) setMessageName _ _ = error "setMessageName on CryptoMessage without message name field." messageName :: (Functor f, HasMessageName x) => (MessageName -> f MessageName) -> (x -> f x) messageName = lens getMessageName setMessageName data KnownLossyness = KnownLossy | KnownLossless deriving (Eq,Ord,Show,Enum) data MessageType = Msg MessageID | GrpMsg KnownLossyness MessageName deriving (Eq,Show) class AsWord16 a where toWord16 :: a -> Word16 fromWord16 :: Word16 -> a class AsWord64 a where toWord64 :: a -> Word64 fromWord64 :: Word64 -> a toEnum8 :: (Enum a, Integral word8) => word8 -> a toEnum8 = toEnum . fromIntegral fromEnum8 :: Enum a => a -> Word8 fromEnum8 = fromIntegral . fromEnum fromEnum16 :: Enum a => a -> Word16 fromEnum16 = fromIntegral . fromEnum fromEnum64 :: Enum a => a -> Word64 fromEnum64 = 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) = 512 + 256 * (fromEnum16 lsy) + fromIntegral (fromEnum8 msgName) fromWord16 x | x < 256 = Msg (toEnum $ fromIntegral x) fromWord16 x | x < 1024, x .|. 0x0200 == 0x0200 = GrpMsg (toEnum8 ((x - 512) `div` 256)) (toEnum8 x) fromWord16 x = error "Not clear how to convert Word16 to MessageType" instance AsWord64 MessageType where toWord64 (Msg msgID) = fromIntegral (fromIntegral (fromEnum16 msgID) :: Word8) toWord64 (GrpMsg lsy msgName) = 512 + 256 * (fromEnum64 lsy) + fromIntegral (fromEnum8 msgName) fromWord64 x | x < 256 = Msg (toEnum $ fromIntegral x) fromWord64 x | x < 1024, x .|. 0x0200 == 0x0200 = GrpMsg (toEnum8 ((x - 512) `div` 256)) (toEnum8 x) fromWord64 x = error "Not clear how to convert Word64 to MessageType" word16 :: (Functor f, AsWord16 x) => (Word16 -> f Word16) -> (x -> f x) word16 = lens toWord16 (\_ x -> fromWord16 x) instance Ord MessageType where compare (Msg x) (Msg y) = compare x y compare (GrpMsg lx x) (GrpMsg ly y) = let r1 = compare lx ly in if r1==EQ then compare x y else r1 compare (Msg _) (GrpMsg _ _) = LT compare (GrpMsg _ _) (Msg _) = GT 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 MESSAGE_GROUPCHAT _) = GrpMsg KnownLossless (getMessageName m) getMessageType m@(UpToN LOSSY_GROUPCHAT _) = GrpMsg KnownLossy (getMessageName m) getMessageType (UpToN mid _) = Msg mid setMessageType (OneByte _ ) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT B.empty ) mname setMessageType (TwoByte _ x) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT (B.singleton x)) mname setMessageType (OneByte _ ) (GrpMsg KnownLossy mname) = setMessageName (UpToN LOSSY_GROUPCHAT B.empty ) mname setMessageType (TwoByte _ x) (GrpMsg KnownLossy mname) = setMessageName (UpToN LOSSY_GROUPCHAT (B.singleton x)) mname setMessageType (UpToN _ x) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT x) mname setMessageType (UpToN _ x) (GrpMsg KnownLossy mname) = setMessageName (UpToN LOSSY_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 instance HasMessageType CryptoData where getMessageType (CryptoData { bufferData }) = getMessageType bufferData setMessageType cd@(CryptoData { bufferData=bd }) typ = cd { bufferData=setMessageType bd typ } -- | 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 getMessageData :: x -> MessageData setMessageData :: x -> MessageData -> x instance HasMessageData CryptoMessage where getMessageData (UpToN (fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 9 -> (_,mdata))) = mdata getMessageData (UpToN (fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 9 -> (_,mdata))) = mdata getMessageData (UpToN (fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 2 -> (_,B.uncons -> Just (0x09,peerinfos)))) = peerinfos -- getMessageData on 0x62:0a is equivalent to getTitle but without decoding the utf8 getMessageData (UpToN (fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 2 -> (_,B.uncons -> Just (0x0a,title)))) = title getMessageData _ = error "getMessageData on CryptoMessage without message data field." setMessageData (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 9 -> (bs,xs))) messagedata -- MESSAGE_GROUPCHAT = UpToN xE (B.concat [bs,messagedata]) setMessageData (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 9 -> (bs,xs))) messagedata -- LOSSY_GROUPCHAT = UpToN xE (B.concat [bs,messagedata]) setMessageData (UpToN xE@(fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 3 -> (bs,xs))) peerinfosOrTitle -- peer/title response packets = UpToN xE (B.concat [bs,peerinfosOrTitle]) setMessageData _ _ = error "setMessageData on CryptoMessage without message data field." messageData :: (Functor f, HasMessageData x) => (MessageData -> f MessageData) -> (x -> f x) messageData = lens getMessageData setMessageData class HasTitle x where getTitle :: x -> Text setTitle :: x -> Text -> x instance HasTitle CryptoMessage where getTitle (UpToN DIRECT_GROUPCHAT {-Ox62-} (sizedAtLeastN 3 -> B.splitAt 2 -> (_,B.uncons -> Just (0x0a,mdata)))) = decodeUtf8 mdata getTitle (UpToN xE (sizedAtLeastN 9 -> B.splitAt 8 -> (_,B.uncons -> Just (toEnum . fromIntegral -> GroupchatTitleChange,mdata)))) | isIndirectGrpChat xE = decodeUtf8 mdata getTitle _ = error "getTitle on CryptoMessage without title field." setTitle (UpToN xE@DIRECT_GROUPCHAT {-0x62-} (sizedAtLeastN 3 -> B.splitAt 2 -> (bs,B.uncons -> Just (_,xs)))) messagedata = UpToN xE (B.concat [bs,B.cons 0x0a (encodeUtf8 messagedata)]) setTitle (UpToN xE (sizedAtLeastN 9 -> B.splitAt 8 -> (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 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)))) | 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 | 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) name = lens getTitle setTitle data PeerInfo = PeerInfo { piPeerNum :: PeerNumber , piUserKey :: PublicKey , piDHTKey :: PublicKey , piName :: ByteString -- byte-prefix for length } deriving (Eq,Show) instance HasPeerNumber PeerInfo where getPeerNumber = piPeerNum setPeerNumber x n = x { piPeerNum = n } instance Serialize PeerInfo where get = do w16 <- get ukey <- id2key <$> get dkey <- id2key <$> get w8 <- get :: Get Word8 PeerInfo w16 ukey dkey <$> getBytes (fromIntegral w8) put (PeerInfo w16 ukey dkey bs) = do put w16 put $ key2id ukey put $ key2id dkey let sz :: Word8 sz = case B.length bs of n | n <= 255 -> fromIntegral n | otherwise -> 255 put sz putByteString $ B.take (fromIntegral sz) bs -- | -- default constructor, handy for formations such as: -- -- > userStatus .~ Busy $ msg USERSTATUS -- msg :: MessageID -> CryptoMessage msg mid | Just (True,0) <- msgSizeParam mid = OneByte mid msg mid | Just (True,1) <- msgSizeParam mid = TwoByte mid 0 msg mid | Just (False,_) <- msgSizeParam mid = UpToN mid B.empty msg mid = UpToN mid B.empty leaveMsg :: Serialize a => a -> CryptoMessage leaveMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x01) peerQueryMsg :: Serialize a => a -> CryptoMessage peerQueryMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x08) -- | Returns if the given message is of fixed(OneByte/TwoByte) size, as well as -- the maximum allowed size for the message Payload (message minus id) -- Or Nothing if unknown/unimplemented. msgSizeParam :: MessageID -> Maybe (Bool,Int) msgSizeParam ONLINE = Just (True,0) msgSizeParam OFFLINE = Just (True,0) msgSizeParam USERSTATUS = Just (True,1) msgSizeParam TYPING = Just (True,1) msgSizeParam NICKNAME = Just (False,128) msgSizeParam STATUSMESSAGE = Just (False,1007) msgSizeParam MESSAGE = Just (False,1372) msgSizeParam ACTION = Just (False,1372) msgSizeParam FILE_DATA = Just (False,1372)-- up to 1373 msgSizeParam FILE_SENDREQUEST = Just (False,300) -- 1+1+4+8+32+max255 = up to 301 msgSizeParam FILE_CONTROL = Just (False,7) -- 8 bytes if seek, otherwise 4 msgSizeParam INVITE_GROUPCHAT = Just (False,38) msgSizeParam ONLINE_PACKET = Just (True,35) msgSizeParam DIRECT_GROUPCHAT {-0x62-} = Nothing -- 1+2+1 thus Just (True,3) leave & peer-query, but variable in response packets msgSizeParam MESSAGE_GROUPCHAT {-0x63-} = Nothing -- variable msgSizeParam LOSSY_GROUPCHAT {-0xC7-} = Nothing -- variable msgSizeParam _ = Nothing isIndirectGrpChat :: MessageID -> Bool isIndirectGrpChat MESSAGE_GROUPCHAT = True isIndirectGrpChat LOSSY_GROUPCHAT = True isIndirectGrpChat _ = False data LossyOrLossless = UnknownLossyness | Lossless | Lossy deriving (Eq,Ord,Enum,Show,Bounded) lossyness :: MessageID -> LossyOrLossless lossyness (fromEnum -> x) | x < 3 = Lossy lossyness (fromEnum -> x) | x >= 16, x < 192 = Lossless lossyness (fromEnum -> x) | x >= 192, x < 255 = Lossy lossyness (fromEnum -> 255) = Lossless lossyness _ = UnknownLossyness isKillPacket :: MessageType -> Bool isKillPacket (Msg KillPacket) = True isKillPacket _ = False isOFFLINE :: MessageType -> Bool isOFFLINE (Msg OFFLINE) = True isOFFLINE _ = False -- TODO: Flesh this out. data MessageID -- First byte indicates data = Padding -- ^ 0 padding (skipped until we hit a non zero (data id) byte) | PacketRequest -- ^ 1 packet request packet (lossy packet) | KillPacket -- ^ 2 connection kill packet (lossy packet) | UnspecifiedPacket003 -- ^ 3+ unspecified | UnspecifiedPacket004 | UnspecifiedPacket005 | UnspecifiedPacket006 | UnspecifiedPacket007 | UnspecifiedPacket008 | UnspecifiedPacket009 | UnspecifiedPacket010 | UnspecifiedPacket011 | UnspecifiedPacket012 | UnspecifiedPacket013 | UnspecifiedPacket014 | UnspecifiedPacket015 | PING -- ^ 16+ reserved for Messenger usage (lossless packets) | MessengerLossless017 | MessengerLossless018 | MessengerLossless019 | MessengerLossless020 | MessengerLossless021 | MessengerLossless022 | MessengerLossless023 | ONLINE -- 1 byte | OFFLINE -- 1 byte | MessengerLossless026 | MessengerLossless027 | MessengerLossless028 | MessengerLossless029 | MessengerLossless030 | MessengerLossless031 | MessengerLossless032 | MessengerLossless033 | MessengerLossless034 | MessengerLossless035 | MessengerLossless036 | MessengerLossless037 | MessengerLossless038 | MessengerLossless039 | MessengerLossless040 | MessengerLossless041 | MessengerLossless042 | MessengerLossless043 | MessengerLossless044 | MessengerLossless045 | MessengerLossless046 | MessengerLossless047 | NICKNAME -- up to 129 bytes | STATUSMESSAGE -- up to 1008 bytes | USERSTATUS -- 2 bytes | TYPING -- 2 bytes | MessengerLossless052 | MessengerLossless053 | MessengerLossless054 | MessengerLossless055 | MessengerLossless056 | MessengerLossless057 | MessengerLossless058 | MessengerLossless059 | MessengerLossless060 | MessengerLossless061 | MessengerLossless062 | MessengerLossless063 | MESSAGE -- up to 1373 bytes | ACTION -- up to 1373 bytes | MessengerLossless066 | MessengerLossless067 | MessengerLossless068 | MSI | MessengerLossless070 | MessengerLossless071 | MessengerLossless072 | MessengerLossless073 | MessengerLossless074 | MessengerLossless075 | MessengerLossless076 | MessengerLossless077 | MessengerLossless078 | MessengerLossless079 | FILE_SENDREQUEST -- 1+1+4+8+32+max255 = up to 301 | FILE_CONTROL -- 8 bytes if seek, otherwise 4 | FILE_DATA -- up to 1373 | MessengerLossless083 | MessengerLossless084 | MessengerLossless085 | MessengerLossless086 | MessengerLossless087 | MessengerLossless088 | MessengerLossless089 | MessengerLossless090 | MessengerLossless091 | MessengerLossless092 | MessengerLossless093 | MessengerLossless094 | MessengerLossless095 | INVITE_GROUPCHAT -- 0x60 | ONLINE_PACKET -- 0x61 | DIRECT_GROUPCHAT -- 0x62 | MESSAGE_GROUPCHAT -- 0x63 | MessengerLossless100 | MessengerLossless101 | MessengerLossless102 | MessengerLossless103 | MessengerLossless104 | MessengerLossless105 | MessengerLossless106 | MessengerLossless107 | MessengerLossless108 | MessengerLossless109 | MessengerLossless110 | MessengerLossless111 | MessengerLossless112 | MessengerLossless113 | MessengerLossless114 | MessengerLossless115 | MessengerLossless116 | MessengerLossless117 | MessengerLossless118 | MessengerLossless119 | MessengerLossless120 | MessengerLossless121 | MessengerLossless122 | MessengerLossless123 | MessengerLossless124 | MessengerLossless125 | MessengerLossless126 | MessengerLossless127 | MessengerLossless128 | MessengerLossless129 | MessengerLossless130 | MessengerLossless131 | MessengerLossless132 | MessengerLossless133 | MessengerLossless134 | MessengerLossless135 | MessengerLossless136 | MessengerLossless137 | MessengerLossless138 | MessengerLossless139 | MessengerLossless140 | MessengerLossless141 | MessengerLossless142 | MessengerLossless143 | MessengerLossless144 | MessengerLossless145 | MessengerLossless146 | MessengerLossless147 | MessengerLossless148 | MessengerLossless149 | MessengerLossless150 | MessengerLossless151 | MessengerLossless152 | MessengerLossless153 | MessengerLossless154 | MessengerLossless155 | MessengerLossless156 | MessengerLossless157 | MessengerLossless158 | MessengerLossless159 | MessengerLossless160 | MessengerLossless161 | MessengerLossless162 | MessengerLossless163 | MessengerLossless164 | MessengerLossless165 | MessengerLossless166 | MessengerLossless167 | MessengerLossless168 | MessengerLossless169 | MessengerLossless170 | MessengerLossless171 | MessengerLossless172 | MessengerLossless173 | MessengerLossless174 | MessengerLossless175 | MessengerLossless176 | MessengerLossless177 | MessengerLossless178 | MessengerLossless179 | MessengerLossless180 | MessengerLossless181 | MessengerLossless182 | MessengerLossless183 | MessengerLossless184 | MessengerLossless185 | MessengerLossless186 | MessengerLossless187 | MessengerLossless188 | MessengerLossless189 | MessengerLossless190 | MessengerLossless191 | MessengerLossy192 -- ^ 192+ reserved for Messenger usage (lossy packets) | MessengerLossy193 | MessengerLossy194 | MessengerLossy195 | MessengerLossy196 | MessengerLossy197 | MessengerLossy198 | LOSSY_GROUPCHAT -- 0xC7 | MessengerLossy200 | MessengerLossy201 | MessengerLossy202 | MessengerLossy203 | MessengerLossy204 | MessengerLossy205 | MessengerLossy206 | MessengerLossy207 | MessengerLossy208 | MessengerLossy209 | MessengerLossy210 | MessengerLossy211 | MessengerLossy212 | MessengerLossy213 | MessengerLossy214 | MessengerLossy215 | MessengerLossy216 | MessengerLossy217 | MessengerLossy218 | MessengerLossy219 | MessengerLossy220 | MessengerLossy221 | MessengerLossy222 | MessengerLossy223 | MessengerLossy224 | MessengerLossy225 | MessengerLossy226 | MessengerLossy227 | MessengerLossy228 | MessengerLossy229 | MessengerLossy230 | MessengerLossy231 | MessengerLossy232 | MessengerLossy233 | MessengerLossy234 | MessengerLossy235 | MessengerLossy236 | MessengerLossy237 | MessengerLossy238 | MessengerLossy239 | MessengerLossy240 | MessengerLossy241 | MessengerLossy242 | MessengerLossy243 | MessengerLossy244 | MessengerLossy245 | MessengerLossy246 | MessengerLossy247 | MessengerLossy248 | MessengerLossy249 | MessengerLossy250 | MessengerLossy251 | MessengerLossy252 | MessengerLossy253 | MessengerLossy254 | Messenger255 -- ^ 255 reserved for Messenger usage (lossless packet) deriving (Show,Eq,Enum,Ord,Bounded) data MessageName = Ping -- 0x00 | MessageName0x01 | MessageName0x02 | MessageName0x03 | MessageName0x04 | MessageName0x05 | MessageName0x06 | MessageName0x07 | MessageName0x08 | MessageName0x09 | MessageName0x0a | MessageName0x0b | MessageName0x0c | MessageName0x0d | MessageName0x0e | MessageName0x0f | NewPeer -- 0x10 | KillPeer -- 0x11 | MessageName0x12 | MessageName0x13 | MessageName0x14 | MessageName0x15 | MessageName0x16 | MessageName0x17 | MessageName0x18 | MessageName0x19 | MessageName0x1a | MessageName0x1b | MessageName0x1c | MessageName0x1d | MessageName0x1e | MessageName0x1f | MessageName0x20 | MessageName0x21 | MessageName0x22 | MessageName0x23 | MessageName0x24 | MessageName0x25 | MessageName0x26 | MessageName0x27 | MessageName0x28 | MessageName0x29 | MessageName0x2a | MessageName0x2b | MessageName0x2c | MessageName0x2d | MessageName0x2e | MessageName0x2f | NameChange -- 0x30 | GroupchatTitleChange -- 0x31 | MessageName0x32 | MessageName0x33 | MessageName0x34 | MessageName0x35 | MessageName0x36 | MessageName0x37 | MessageName0x38 | MessageName0x39 | MessageName0x3a | MessageName0x3b | MessageName0x3c | MessageName0x3d | MessageName0x3e | MessageName0x3f | ChatMessage -- 0x40 | Action -- 0x41 | MessageName0x42 | MessageName0x43 | MessageName0x44 | MessageName0x45 | MessageName0x46 | MessageName0x47 | MessageName0x48 | MessageName0x49 | MessageName0x4a | MessageName0x4b | MessageName0x4c | MessageName0x4d | MessageName0x4e | MessageName0x4f | MessageName0x50 | MessageName0x51 | MessageName0x52 | MessageName0x53 | MessageName0x54 | MessageName0x55 | MessageName0x56 | MessageName0x57 | MessageName0x58 | MessageName0x59 | MessageName0x5a | MessageName0x5b | MessageName0x5c | MessageName0x5d | MessageName0x5e | MessageName0x5f | MessageName0x60 | MessageName0x61 | MessageName0x62 | MessageName0x63 | MessageName0x64 | MessageName0x65 | MessageName0x66 | MessageName0x67 | MessageName0x68 | MessageName0x69 | MessageName0x6a | MessageName0x6b | MessageName0x6c | MessageName0x6d | MessageName0x6e | MessageName0x6f | MessageName0x70 | MessageName0x71 | MessageName0x72 | MessageName0x73 | MessageName0x74 | MessageName0x75 | MessageName0x76 | MessageName0x77 | MessageName0x78 | MessageName0x79 | MessageName0x7a | MessageName0x7b | MessageName0x7c | MessageName0x7d | MessageName0x7e | MessageName0x7f | MessageName0x80 | MessageName0x81 | MessageName0x82 | MessageName0x83 | MessageName0x84 | MessageName0x85 | MessageName0x86 | MessageName0x87 | MessageName0x88 | MessageName0x89 | MessageName0x8a | MessageName0x8b | MessageName0x8c | MessageName0x8d | MessageName0x8e | MessageName0x8f | MessageName0x90 | MessageName0x91 | MessageName0x92 | MessageName0x93 | MessageName0x94 | MessageName0x95 | MessageName0x96 | MessageName0x97 | MessageName0x98 | MessageName0x99 | MessageName0x9a | MessageName0x9b | MessageName0x9c | MessageName0x9d | MessageName0x9e | MessageName0x9f | MessageName0xa0 | MessageName0xa1 | MessageName0xa2 | MessageName0xa3 | MessageName0xa4 | MessageName0xa5 | MessageName0xa6 | MessageName0xa7 | MessageName0xa8 | MessageName0xa9 | MessageName0xaa | MessageName0xab | MessageName0xac | MessageName0xad | MessageName0xae | MessageName0xaf | MessageName0xb0 | MessageName0xb1 | MessageName0xb2 | MessageName0xb3 | MessageName0xb4 | MessageName0xb5 | MessageName0xb6 | MessageName0xb7 | MessageName0xb8 | MessageName0xb9 | MessageName0xba | MessageName0xbb | MessageName0xbc | MessageName0xbd | MessageName0xbe | MessageName0xbf | MessageName0xc0 | MessageName0xc1 | MessageName0xc2 | MessageName0xc3 | MessageName0xc4 | MessageName0xc5 | MessageName0xc6 | MessageName0xc7 | MessageName0xc8 | MessageName0xc9 | MessageName0xca | MessageName0xcb | MessageName0xcc | MessageName0xcd | MessageName0xce | MessageName0xcf | MessageName0xd0 | MessageName0xd1 | MessageName0xd2 | MessageName0xd3 | MessageName0xd4 | MessageName0xd5 | MessageName0xd6 | MessageName0xd7 | MessageName0xd8 | MessageName0xd9 | MessageName0xda | MessageName0xdb | MessageName0xdc | MessageName0xdd | MessageName0xde | MessageName0xdf | MessageName0xe0 | MessageName0xe1 | MessageName0xe2 | MessageName0xe3 | MessageName0xe4 | MessageName0xe5 | MessageName0xe6 | MessageName0xe7 | MessageName0xe8 | MessageName0xe9 | MessageName0xea | MessageName0xeb | MessageName0xec | MessageName0xed | MessageName0xee | MessageName0xef | MessageName0xf0 | MessageName0xf1 | MessageName0xf2 | MessageName0xf3 | MessageName0xf4 | MessageName0xf5 | MessageName0xf6 | MessageName0xf7 | MessageName0xf8 | MessageName0xf9 | MessageName0xfa | MessageName0xfb | MessageName0xfc | MessageName0xfd | MessageName0xfe | MessageName0xff deriving (Show,Eq,Ord,Enum,Bounded) -- --> CookieRequest WithoutCookie -- <-- CookieResponse CookieAddress -- --> Handshake CookieAddress -- <-- Handshake CookieAddress -- cookie request packet (145 bytes) -- -- [uint8_t 24] -- [Sender's DHT Public key (32 bytes)] -- [Random nonce (24 bytes)] -- [Encrypted message containing: -- [Sender's real public key (32 bytes)] -- [padding (32 bytes)] -- [uint64_t echo id (must be sent back untouched in cookie response)] -- ] -- cookie response packet (161 bytes): -- -- [uint8_t 25] -- [Random nonce (24 bytes)] -- [Encrypted message containing: -- [Cookie] -- [uint64_t echo id (that was sent in the request)] -- ] -- -- Encrypted message is encrypted with the exact same symmetric key as the -- cookie request packet it responds to but with a different nonce. -- (Encrypted message is encrypted with reqesters's DHT private key, -- responders's DHT public key and the nonce.) -- -- Since we don't receive the public key, we will need to lookup the key by -- the SockAddr... I don't understand why the CookieResponse message is -- special this way. TODO: implement a multimap (SockAddr -> SharedSecret) -- and wrap cookie queries with store/delete. TODO: Should the entire -- SharedScret cache be keyed on only SockAddr ? Perhaps the secret cache -- should be (NodeId -> Secret) and the cookie-request map should be -- (SockAddr -> NodeId)