1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
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
|
