dependent-sum based CryptoMessage.

2 files changed, 233 insertions, 1 deletions

diff --git a/src/Data/Tox/Message.hs b/src/Data/Tox/Message.hs
index b77307a2..9f1ce339 100644
--- a/src/Data/Tox/Message.hs
+++ b/src/Data/Tox/Message.hs
@@ -31,7 +31,8 @@ pattern MSI                  = MessageID  69
 pattern FILE_SENDREQUEST     = MessageID  80 -- 1+1+4+8+32+max255 = up to 301
 pattern FILE_CONTROL         = MessageID  81 -- 8 bytes if seek, otherwise 4
 pattern FILE_DATA            = MessageID  82 -- up to 1373
-pattern INVITE_GROUPCHAT     = MessageID  96 -- 0x60
+pattern INVITE_GROUPCHAT     = MessageID  95
+pattern INVITE_GROUPCHAT0    = MessageID  96 -- 0x60
 -- TODO: rename to INVITE_CONFERENCE 96
 pattern ONLINE_PACKET        = MessageID  97 -- 0x61
 pattern DIRECT_GROUPCHAT     = MessageID  98 -- 0x62
diff --git a/src/Data/Tox/Msg.hs b/src/Data/Tox/Msg.hs
new file mode 100644
index 00000000..84fffb12
--- /dev/null
+++ b/src/Data/Tox/Msg.hs
@@ -0,0 +1,231 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DefaultSignatures     #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE KindSignatures        #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds             #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE StandaloneDeriving #-}
+module Data.Tox.Msg where
+
+import Data.ByteString       as B
+import Data.Dependent.Sum
+import Data.GADT.Compare
+import Data.GADT.Show
+import Data.Functor.Identity
+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)
+
+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 Unknown
+    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 (Pkt mid :=> Identity _) = M mid
+
+-- TODO
+instance GShow Pkt where gshowsPrec = showsPrec
+instance ShowTag Pkt Identity where
+    showTaggedPrec (Pkt _) = showsPrec
+
+instance GEq Pkt where geq (Pkt _) (Pkt _) = eqT
+instance EqTag Pkt Identity where eqTagged (Pkt _) (Pkt _) = (==)
+
+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 (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
+