From 11987749fc6e6d3e53ea737d46d5ab13a16faeb8 Mon Sep 17 00:00:00 2001 From: James Crayne Date: Sat, 28 Sep 2019 13:43:29 -0400 Subject: Factor out some new libraries word64-map: Data.Word64Map network-addr: Network.Address tox-crypto: Crypto.Tox lifted-concurrent: Control.Concurrent.Lifted.Instrument Control.Concurrent.Async.Lifted.Instrument psq-wrap: Data.Wrapper.PSQInt Data.Wrapper.PSQ minmax-psq: Data.MinMaxPSQ tasks: Control.Concurrent.Tasks kad: Network.Kademlia Network.Kademlia.Bootstrap Network.Kademlia.Routing Network.Kademlia.CommonAPI Network.Kademlia.Persistence Network.Kademlia.Search --- src/Network/Tox/Crypto/Transport.hs | 1029 ----------------------------------- 1 file changed, 1029 deletions(-) delete mode 100644 src/Network/Tox/Crypto/Transport.hs (limited to 'src/Network/Tox/Crypto') diff --git a/src/Network/Tox/Crypto/Transport.hs b/src/Network/Tox/Crypto/Transport.hs deleted file mode 100644 index a18b550d..00000000 --- a/src/Network/Tox/Crypto/Transport.hs +++ /dev/null @@ -1,1029 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -module Network.Tox.Crypto.Transport - ( showCryptoMsg - , parseCrypto - , encodeCrypto - , unpadCryptoMsg - , decodeRawCryptoMsg - , parseHandshakes - , encodeHandshakes - , CryptoData(..) - , CryptoMessage(..) - , MessageName(..) - , CryptoPacket(..) - , HandshakeData(..) - , Handshake(..) - , PeerInfo(..) - , UserStatus(..) - , TypingStatus(..) - , GroupChatId(..) - , MessageType(..) - , isKillPacket, isOFFLINE - , KnownLossyness(..) - , AsWord16(..) - , AsWord64(..) - -- feild name classes - , HasGroupChatID(..) - , HasGroupNumber(..) - , HasPeerNumber(..) - , HasMessageNumber(..) - , HasMessageName(..) - , HasMessageData(..) - , HasName(..) - , HasTitle(..) - , HasMessage(..) - , HasMessageType(..) - -- lenses -#ifdef USE_lens - , groupNumber, groupNumberToJoin, peerNumber, messageNumber - , messageName, messageData, name, title, message, messageType -#endif - -- constructor - -- utils - , sizedN - , sizedAtLeastN - , isIndirectGrpChat - , fromEnum8 - , fromEnum16 - , toEnum8 - , getCryptoMessage - , putCryptoMessage - ) where - -import Crypto.Tox -import Data.Tox.Msg -import Network.Tox.DHT.Transport (Cookie) -import Network.Tox.NodeId -import DPut -import DebugTag -import Data.PacketBuffer as PB - -import Network.Socket -import Data.ByteArray -import Data.Dependent.Sum - -import Control.Monad -import Data.ByteString as B -import Data.Function -import Data.Maybe -import Data.Monoid -import Data.Word -import Data.Bits -import Crypto.Hash -import Data.Functor.Contravariant -import Data.Functor.Identity -import Data.Text as T -import Data.Text.Encoding as T -import Data.Serialize as S -import Control.Arrow -import GHC.TypeNats - -showCryptoMsg :: Word32 -> CryptoMessage -> [Char] -showCryptoMsg _ msg = show msg - -parseCrypto :: (ByteString, SockAddr) -> Either (CryptoPacket Encrypted, SockAddr) (ByteString, SockAddr) -parseCrypto (bbs,saddr) = case B.uncons bbs of - Just (0x1b,bs) -> case runGet get bs of - Right pkt -> Left (pkt, saddr) -- Successful parse, handle this packet. - Left _ -> Right (bs,saddr) -- Failed parse, strip first byte and pass it on. - _ -> Right (bbs,saddr) -- Type-code mismatch, pass it on. - -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) - -{- -createRequestPacket :: Word32 -> [Word32] -> CryptoMessage -createRequestPacket seqno xs = let r = UpToN PacketRequest (B.pack ns) - in dtrace XNetCrypto ("createRequestPacket " ++ show seqno ++ " " ++ show xs ++ " -----> " ++ show r) r - where - ys = Prelude.map (subtract (seqno - 1)) xs - reduceToSums [] = [] - reduceToSums (x:xs) = x:(reduceToSums $ Prelude.map (subtract x) xs) - makeZeroes :: Word32 -> [Word32] - -- makeZeroes 0 = [] - makeZeroes x - = let (d,m)= x `divMod` 255 - zeros= Prelude.replicate (fromIntegral d) 0 - in zeros ++ [m] - ns :: [Word8] - ns = Prelude.map fromIntegral (reduceToSums ys >>= makeZeroes) --} - -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 recipient to respond to the handshake packet) - } - deriving (Eq,Ord,Show) - -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 - <*> getPublicKey - <*> (fromJust . digestFromByteString <$> getBytes 64) - <*> get - put (HandshakeData n k h c) = do - put n - putPublicKey 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 - } - -deriving instance Show (CryptoPacket Encrypted) - -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 - } deriving (Eq,Show) - -{- -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 = do - ack <- get - seqno <- get - cm <- getCryptoMessage ack - return $ CryptoData ack seqno cm - put (CryptoData ack seqno dta) = do - put ack - put seqno - putCryptoMessage ack dta - -data TypingStatus = NotTyping | Typing deriving (Show,Read,Eq,Ord,Enum) -instance Serialize TypingStatus where - get = do - x <- get :: Get Word8 - return (toEnum8 x) - put x = put (fromEnum8 x :: Word8) - -unpadCryptoMsg :: CryptoMessage -> CryptoMessage -unpadCryptoMsg msg@(Pkt Padding :=> Identity (Padded bs)) = - let unpadded = B.dropWhile (== msgbyte Padding) bs - in either (const msg) id $ runGet (getCryptoMessage 0) unpadded -unpadCryptoMsg msg = msg - -decodeRawCryptoMsg :: CryptoData -> CryptoMessage -decodeRawCryptoMsg (CryptoData ack seqno cm) = unpadCryptoMsg cm - -instance Sized CryptoMessage where - size = VarSize $ \case - Pkt t :=> Identity x -> case sizeFor t of - ConstSize sz -> 1 + sz - VarSize f -> 1 + f x - -sizeFor :: Sized x => p x -> Size x -sizeFor _ = size - - -getCryptoMessage :: Word32 -> Get CryptoMessage -getCryptoMessage seqno = fix $ \stripPadding -> do - t <- getWord8 - case msgTag t of - Just (M Padding) -> stripPadding - Just (M msg) -> do x <- getPacket seqno - return $ Pkt msg ==> x - Nothing -> return $ Pkt MESSAGE ==> "Unhandled packet: " <> T.pack (show t) -- $ Pkt Padding ==> Padded mempty - -putCryptoMessage :: Word32 -> CryptoMessage -> Put -putCryptoMessage seqno (Pkt t :=> Identity x) = do - putWord8 (msgbyte t) - putPacket seqno x - - -#ifdef USE_lens -erCompat :: String -> a -erCompat lens = error $ "Use of '" ++ lens ++ "' lens on incompatible CryptoMessage type" -#endif - - -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 (Pkt INVITE_CONFERENCE :=> Identity 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 (Pkt ONLINE_PACKET :=> Identity payload) = GrpId (B.take 33 $ B.drop 2 (sizedN 35 payload)) - getGroupChatID _ = error "getGroupChatID on non-groupchat message." - - -- Set - setGroupChatID msg@(Pkt INVITE_CONFERENCE :=> Identity 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 (Pkt ONLINE_PACKET :=> Identity payload) (GrpId newid) = Pkt ONLINE_PACKET ==> (B.concat [B.take 2 payload, sizedN 33 newid]) - setGroupChatID _ _= error "setGroupChatID on non-groupchat message." --} - -#ifdef USE_lens -groupChatID :: (Functor f, HasGroupChatID x) => (GroupChatId -> f GroupChatId) -> (x -> f x) -groupChatID = lens getGroupChatID setGroupChatID -#endif - -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 (Pkt INVITE_CONFERENCE :=> Identity (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." --} - -#ifdef USE_lens -groupNumber :: (Functor f, HasGroupNumber x) => (Word16 -> f Word16) -> (x -> f x) -groupNumber = lens getGroupNumber setGroupNumber -#endif - -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." --} - -#ifdef USE_lens -groupNumberToJoin :: (Functor f, HasGroupNumberToJoin x) => (GroupNumber -> f GroupNumber) -> (x -> f x) -groupNumberToJoin = lens getGroupNumberToJoin setGroupNumberToJoin -#endif - -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." --} - -#ifdef USE_lens -peerNumber :: (Functor f, HasPeerNumber x) => (Word16 -> f Word16) -> (x -> f x) -peerNumber = lens getPeerNumber setPeerNumber -#endif - -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." --} - -#ifdef USE_lens -messageNumber :: (Functor f, HasMessageNumber x) => (Word32 -> f Word32) -> (x -> f x) -messageNumber = lens getMessageNumber setMessageNumber -#endif - -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." --} - -#ifdef USE_lens -messageName :: (Functor f, HasMessageName x) => (MessageName -> f MessageName) -> (x -> f x) -messageName = lens getMessageName setMessageName -#endif - -data KnownLossyness = KnownLossy | KnownLossless - deriving (Eq,Ord,Show,Enum) - -data MessageType = Msg Word8 - | 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 - - -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" - -#ifdef USE_lens -word16 :: (Functor f, AsWord16 x) => (Word16 -> f Word16) -> (x -> f x) -word16 = lens toWord16 (\_ x -> fromWord16 x) -#endif - -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 } --} - -#ifdef USE_lens --- | This lens should always succeed on CryptoMessage -messageType :: (Functor f, HasMessageType x) => (MessageType -> f MessageType) -> (x -> f x) -messageType = lens getMessageType setMessageType -#endif - -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." --} - -#ifdef USE_lens -messageData :: (Functor f, HasMessageData x) => (MessageData -> f MessageData) -> (x -> f x) -messageData = lens getMessageData setMessageData -#endif - -class HasTitle x where - getTitle :: x -> Text - setTitle :: x -> Text -> x - -{- -instance HasTitle CryptoMessage where - getTitle (UpToN xE bs) - | DIRECT_GROUPCHAT {-0x62-} <- xE, - (_,0x0a,mdata) <- splitByteAt 2 bs = decodeUtf8 mdata - | isIndirectGrpChat xE, - let (_,nmb,mdata) = splitByteAt 8 bs - nm = toEnum (fromIntegral nmb), - GroupchatTitleChange <- nm = decodeUtf8 mdata - getTitle _ = error "getTitle on CryptoMessage without title field." - - setTitle (UpToN xE bs) msgdta - | DIRECT_GROUPCHAT {-0x62-} <- xE - = let (pre,_,_) = splitByteAt 2 bs - nm = 0x0a - in UpToN xE (pre <> B.cons nm (encodeUtf8 msgdta)) - | isIndirectGrpChat xE - = let (pre,_,_) = splitByteAt 8 bs - nm = fromIntegral $ fromEnum GroupchatTitleChange - in UpToN xE (pre <> B.cons nm (encodeUtf8 msgdta)) - setTitle _ _ = error "setTitle on CryptoMessage without title field." --} - -#ifdef USE_lens -title :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x) -title = lens getTitle setTitle -#endif - -class HasMessage x where - getMessage :: x -> Text - setMessage :: x -> Text -> x - -splitByteAt :: Int -> ByteString -> (ByteString,Word8,ByteString) -splitByteAt n bs = (fixed,w8,bs') - where - (fixed,B.uncons -> Just (w8,bs')) = B.splitAt n $ sizedAtLeastN (n+1) bs - -{- -instance HasMessage CryptoMessage where - getMessage (UpToN xE bs) - | MESSAGE <- xE = T.decodeUtf8 bs - | isIndirectGrpChat xE = T.decodeUtf8 mdata where (_,_,mdata) = splitByteAt 8 bs - getMessage _ = error "getMessage on CryptoMessage without message field." - - setMessage (UpToN xE bs) message - | MESSAGE <- xE - = UpToN xE $ T.encodeUtf8 message - | isIndirectGrpChat xE - = let (pre8,nm0,xs) = splitByteAt 8 bs - nm = if nm0 == 0 then 0x40 else nm0 - prefix x = pre8 <> B.cons nm x - in UpToN xE $ prefix $ T.encodeUtf8 message - setMessage _ _ = error "setMessage on CryptoMessage without message field." --} - -#ifdef USE_lens -message :: (Functor f, HasMessage x) => (Text -> f Text) -> (x -> f x) -message = lens getMessage setMessage -#endif - -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." --} - -#ifdef USE_lens -name :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x) -name = lens getTitle setTitle -#endif - -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 <- getPublicKey - dkey <- getPublicKey - w8 <- get :: Get Word8 - PeerInfo w16 ukey dkey <$> getBytes (fromIntegral w8) - - put (PeerInfo w16 ukey dkey bs) = do - put w16 - putPublicKey ukey - putPublicKey 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 - | Just (True,1) <- msgSizeParam mid = TwoByte mid 0 - | Just (False,_) <- msgSizeParam mid = UpToN mid B.empty - | otherwise = UpToN mid B.empty --} - -{- -leaveMsg, peerQueryMsg :: Serialize a => a -> CryptoMessage -leaveMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x01) -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 :: Msg n t -> Bool -isIndirectGrpChat MESSAGE_CONFERENCE = True -isIndirectGrpChat LOSSY_CONFERENCE = True -isIndirectGrpChat _ = False - -isKillPacket :: SomeMsg -> Bool -isKillPacket (M KillPacket) = True -isKillPacket _ = False - -isOFFLINE :: SomeMsg -> Bool -isOFFLINE (M OFFLINE) = True -isOFFLINE _ = False - - -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) - -- cgit v1.2.3