path: root/dht/src/Data/Tox/Msg.hs

{-# 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