{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Data.Tox.Msg where import Crypto.Error import qualified Crypto.PubKey.Ed25519 as Ed25519 import Data.ByteArray as BA import Data.ByteString as B import Data.Constraint import Data.Dependent.Sum import Data.Functor.Contravariant import Data.Functor.Identity import Data.GADT.Compare import Data.GADT.Show import Data.Monoid import Data.Serialize import Data.Text as T import Data.Text.Encoding as T import Data.Typeable import Data.Word import GHC.TypeLits import Crypto.Tox import Data.PacketBuffer (compressSequenceNumbers, decompressSequenceNumbers) import Network.Tox.NodeId #if MIN_VERSION_dependent_sum(0,6,0) import Data.Constraint.Compose import Data.Constraint.Extras import Data.Constraint.Extras.TH #endif newtype Unknown = Unknown B.ByteString deriving (Eq,Show) newtype Padded = Padded B.ByteString deriving (Eq,Show) -- 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) instance Serialize UserStatus where get = do x <- get :: Get Word8 return (toEnum8 x) put x = put (fromEnum8 x) newtype MissingPackets = MissingPackets [Word32] deriving (Eq,Show) data Msg (n :: Nat) t where Padding :: Msg 0 Padded PacketRequest :: Msg 1 MissingPackets KillPacket :: Msg 2 () ALIVE :: Msg 16 () SHARE_RELAYS :: Msg 17 Unknown FRIEND_REQUESTS :: Msg 18 Unknown ONLINE :: Msg 24 () OFFLINE :: Msg 25 () NICKNAME :: Msg 48 Text STATUSMESSAGE :: Msg 49 Text USERSTATUS :: Msg 50 UserStatus TYPING :: Msg 51 Bool MESSAGE :: Msg 64 Text ACTION :: Msg 65 Text MSI :: Msg 69 Unknown FILE_SENDREQUEST :: Msg 80 Unknown FILE_CONTROL :: Msg 81 Unknown FILE_DATA :: Msg 82 Unknown INVITE_GROUPCHAT :: Msg 95 Invite INVITE_CONFERENCE :: Msg 96 Unknown ONLINE_PACKET :: Msg 97 Unknown DIRECT_CONFERENCE :: Msg 98 Unknown MESSAGE_CONFERENCE :: Msg 99 Unknown LOSSY_CONFERENCE :: Msg 199 Unknown deriving instance Show (Msg n a) msgbyte :: KnownNat n => Msg n a -> Word8 msgbyte m = fromIntegral (natVal $ proxy m) where proxy :: Msg n a -> Proxy n proxy _ = Proxy data Pkt a where Pkt :: (KnownNat n, Packet a, KnownMsg n) => Msg n a -> Pkt a deriving instance (Show (Pkt a)) type CryptoMessage = DSum Pkt Identity msgID :: DSum Pkt Identity -> SomeMsg msgID (Pkt mid :=> Identity _) = M mid -- TODO instance GShow Pkt where gshowsPrec = showsPrec instance GEq Pkt where geq (Pkt _) (Pkt _) = eqT someMsgVal :: KnownMsg n => Msg n a -> SomeMsg someMsgVal m = msgid (proxy m) where proxy :: Msg n a -> Proxy n proxy _ = Proxy class KnownMsg (n::Nat) where msgid :: proxy n -> SomeMsg instance KnownMsg 0 where msgid _ = M Padding instance KnownMsg 1 where msgid _ = M PacketRequest instance KnownMsg 2 where msgid _ = M KillPacket instance KnownMsg 16 where msgid _ = M ALIVE instance KnownMsg 17 where msgid _ = M SHARE_RELAYS instance KnownMsg 18 where msgid _ = M FRIEND_REQUESTS instance KnownMsg 24 where msgid _ = M ONLINE instance KnownMsg 25 where msgid _ = M OFFLINE instance KnownMsg 48 where msgid _ = M NICKNAME instance KnownMsg 49 where msgid _ = M STATUSMESSAGE instance KnownMsg 50 where msgid _ = M USERSTATUS instance KnownMsg 51 where msgid _ = M TYPING instance KnownMsg 64 where msgid _ = M MESSAGE instance KnownMsg 65 where msgid _ = M ACTION instance KnownMsg 69 where msgid _ = M MSI instance KnownMsg 80 where msgid _ = M FILE_SENDREQUEST instance KnownMsg 81 where msgid _ = M FILE_CONTROL instance KnownMsg 82 where msgid _ = M FILE_DATA instance KnownMsg 95 where msgid _ = M INVITE_GROUPCHAT instance KnownMsg 96 where msgid _ = M INVITE_CONFERENCE instance KnownMsg 97 where msgid _ = M ONLINE_PACKET instance KnownMsg 98 where msgid _ = M DIRECT_CONFERENCE instance KnownMsg 99 where msgid _ = M MESSAGE_CONFERENCE msgTag :: Word8 -> Maybe SomeMsg msgTag 0 = Just $ M Padding msgTag 1 = Just $ M PacketRequest msgTag 2 = Just $ M KillPacket msgTag 16 = Just $ M ALIVE msgTag 17 = Just $ M SHARE_RELAYS msgTag 18 = Just $ M FRIEND_REQUESTS msgTag 24 = Just $ M ONLINE msgTag 25 = Just $ M OFFLINE msgTag 48 = Just $ M NICKNAME msgTag 49 = Just $ M STATUSMESSAGE msgTag 50 = Just $ M USERSTATUS msgTag 51 = Just $ M TYPING msgTag 64 = Just $ M MESSAGE msgTag 65 = Just $ M ACTION msgTag 69 = Just $ M MSI msgTag 80 = Just $ M FILE_SENDREQUEST msgTag 81 = Just $ M FILE_CONTROL msgTag 82 = Just $ M FILE_DATA msgTag 95 = Just $ M INVITE_GROUPCHAT msgTag 96 = Just $ M INVITE_CONFERENCE msgTag 97 = Just $ M ONLINE_PACKET msgTag 98 = Just $ M DIRECT_CONFERENCE msgTag 99 = Just $ M MESSAGE_CONFERENCE msgTag _ = Nothing class (Typeable t, Eq t, Show t, Sized t) => Packet t where getPacket :: Word32 -> Get t putPacket :: Word32 -> t -> Put default getPacket :: Serialize t => Word32 -> Get t getPacket _ = get default putPacket :: Serialize t => Word32 -> t -> Put putPacket _ t = put t instance Sized UserStatus where size = ConstSize 1 instance Packet UserStatus instance Sized () where size = ConstSize 0 instance Packet () where getPacket _ = return () putPacket _ _ = return () instance Sized MissingPackets where size = VarSize $ \(MissingPackets ws) -> Prelude.length ws instance Packet MissingPackets where getPacket seqno = do bs <- B.unpack <$> (remaining >>= getBytes) return $ MissingPackets (decompressSequenceNumbers seqno bs) putPacket seqno (MissingPackets ws) = do mapM_ putWord8 $ compressSequenceNumbers seqno ws instance Sized Unknown where size = VarSize $ \(Unknown bs) -> B.length bs instance Packet Unknown where getPacket _ = Unknown <$> (remaining >>= getBytes) putPacket _ (Unknown bs) = putByteString bs instance Sized Padded where size = VarSize $ \(Padded bs) -> B.length bs instance Packet Padded where getPacket _ = Padded <$> (remaining >>= getBytes) putPacket _ (Padded bs) = putByteString bs instance Sized Text where size = VarSize (B.length . T.encodeUtf8) instance Packet Text where getPacket _ = T.decodeUtf8 <$> (remaining >>= getBytes) putPacket _ = putByteString . T.encodeUtf8 instance Sized Bool where size = ConstSize 1 instance Packet Bool where getPacket _ = (/= 0) <$> getWord8 putPacket _ False = putWord8 0 putPacket _ True = putWord8 1 data SomeMsg where M :: (KnownMsg n, KnownNat n, Packet t) => Msg n t -> SomeMsg instance Eq SomeMsg where M m == M n = msgbyte m == msgbyte n instance Show SomeMsg where show (M m) = show m toEnum8 :: (Enum a, Integral word8) => word8 -> a toEnum8 = toEnum . fromIntegral fromEnum8 :: Enum a => a -> Word8 fromEnum8 = fromIntegral . fromEnum data LossyOrLossless = Lossless | Lossy deriving (Eq,Ord,Enum,Show,Bounded) someLossyness :: SomeMsg -> LossyOrLossless someLossyness (M m) = lossyness m lossyness :: KnownNat n => Msg n t -> LossyOrLossless lossyness m = case msgbyte m of x | x < 3 -> Lossy | {-16 <= x,-} x < 192 -> Lossless | 192 <= x, x < 255 -> Lossy | otherwise -> Lossless newtype ChatID = ChatID Ed25519.PublicKey deriving Eq instance Sized ChatID where size = ConstSize 32 instance Serialize ChatID where get = do bs <- getBytes 32 case Ed25519.publicKey bs of CryptoPassed ed -> return $ ChatID ed CryptoFailed e -> fail (show e) put (ChatID ed) = putByteString $ BA.convert ed instance Read ChatID where readsPrec _ s | Right bs <- parseBase64Key256 s , CryptoPassed ed <- Ed25519.publicKey bs = [ (ChatID ed, Prelude.drop 43 s) ] | otherwise = [] instance Show ChatID where show (ChatID ed) = showBase64Key256 ed data InviteType = GroupInvite { groupName :: Text } | AcceptedInvite | ConfirmedInvite { inviteNodes :: [NodeInfo] } deriving (Eq,Show) instance Sized InviteType where size = VarSize $ \x -> case x of GroupInvite name -> B.length (T.encodeUtf8 name) AcceptedInvite -> 0 ConfirmedInvite ns -> 0 -- TODO: size of node list. data Invite = Invite { inviteChatID :: ChatID , inviteChatKey :: PublicKey , invite :: InviteType } deriving (Eq,Show) instance Sized Invite where size = contramap inviteChatID size <> contramap (key2id . inviteChatKey) size <> contramap invite size instance Serialize Invite where get = do group_packet_id <- getWord8 -- expecting 254=GP_FRIEND_INVITE invite_type <- getWord8 chatid <- get chatkey <- getPublicKey Invite chatid chatkey <$> case invite_type of 0 -> do bs <- remaining >>= getBytes -- TODO: size can be determined from group shared state. return $ GroupInvite $ decodeUtf8 bs 1 -> return AcceptedInvite 2 -> return $ ConfirmedInvite [] -- TODO: decode nodes put x = do putWord8 254 -- GP_FRIEND_INVITE putWord8 $ case invite x of GroupInvite {} -> 0 -- GROUP_INVITE AcceptedInvite -> 1 -- GROUP_INVITE_ACCEPTED ConfirmedInvite {} -> 2 -- GROUP_INVITE_CONFIRMATION put $ inviteChatID x putPublicKey $ inviteChatKey x case invite x of GroupInvite name -> putByteString $ encodeUtf8 name AcceptedInvite -> return () ConfirmedInvite ns -> return () -- TODO: encode nodes. instance Packet Invite where #if MIN_VERSION_dependent_sum(0,6,0) -- deriveArgDict ''Pkt instance ArgDict (ComposeC Show Identity) Pkt where type ConstraintsFor Pkt (ComposeC Show Identity) = () argDict (Pkt _) = Dict instance ArgDict (ComposeC Eq Identity) Pkt where type ConstraintsFor Pkt (ComposeC Eq Identity) = () argDict (Pkt _) = Dict #else instance EqTag Pkt Identity where eqTagged (Pkt _) (Pkt _) = (==) instance ShowTag Pkt Identity where showTaggedPrec (Pkt _) = showsPrec #endif