summaryrefslogtreecommitdiff
path: root/src/Data/Tox/Msg.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Data/Tox/Msg.hs')
-rw-r--r--src/Data/Tox/Msg.hs311
1 files changed, 0 insertions, 311 deletions
diff --git a/src/Data/Tox/Msg.hs b/src/Data/Tox/Msg.hs
deleted file mode 100644
index 66ec6eb1..00000000
--- a/src/Data/Tox/Msg.hs
+++ /dev/null
@@ -1,311 +0,0 @@
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DefaultSignatures #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE KindSignatures #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE StandaloneDeriving #-}
10{-# LANGUAGE TypeFamilies #-}
11module Data.Tox.Msg where
12
13import Crypto.Error
14import qualified Crypto.PubKey.Ed25519 as Ed25519
15import Data.ByteArray as BA
16import Data.ByteString as B
17import Data.Dependent.Sum
18import Data.Functor.Contravariant
19import Data.Functor.Identity
20import Data.GADT.Compare
21import Data.GADT.Show
22import Data.Monoid
23import Data.Serialize
24import Data.Text as T
25import Data.Text.Encoding as T
26import Data.Typeable
27import Data.Word
28import GHC.TypeLits
29
30import Crypto.Tox
31import Data.PacketBuffer (compressSequenceNumbers, decompressSequenceNumbers)
32import Network.Tox.NodeId
33
34newtype Unknown = Unknown B.ByteString deriving (Eq,Show)
35newtype Padded = Padded B.ByteString deriving (Eq,Show)
36
37-- The 'UserStatus' equivalent in Presence is:
38--
39-- data JabberShow = Offline
40-- | ExtendedAway
41-- | Away -- Tox equiv: Away (1)
42-- | DoNotDisturb -- Tox equiv: Busy (2)
43-- | Available -- Tox equiv: Online (0)
44-- | Chatty
45-- deriving (Show,Enum,Ord,Eq,Read)
46--
47-- The Enum instance on 'UserStatus' is not arbitrary. It corresponds
48-- to on-the-wire id numbers.
49data UserStatus = Online | Away | Busy deriving (Show,Read,Eq,Ord,Enum)
50
51instance Serialize UserStatus where
52 get = do
53 x <- get :: Get Word8
54 return (toEnum8 x)
55 put x = put (fromEnum8 x)
56
57
58newtype MissingPackets = MissingPackets [Word32]
59 deriving (Eq,Show)
60
61data Msg (n :: Nat) t where
62 Padding :: Msg 0 Padded
63 PacketRequest :: Msg 1 MissingPackets
64 KillPacket :: Msg 2 ()
65 ALIVE :: Msg 16 ()
66 SHARE_RELAYS :: Msg 17 Unknown
67 FRIEND_REQUESTS :: Msg 18 Unknown
68 ONLINE :: Msg 24 ()
69 OFFLINE :: Msg 25 ()
70 NICKNAME :: Msg 48 Text
71 STATUSMESSAGE :: Msg 49 Text
72 USERSTATUS :: Msg 50 UserStatus
73 TYPING :: Msg 51 Bool
74 MESSAGE :: Msg 64 Text
75 ACTION :: Msg 65 Text
76 MSI :: Msg 69 Unknown
77 FILE_SENDREQUEST :: Msg 80 Unknown
78 FILE_CONTROL :: Msg 81 Unknown
79 FILE_DATA :: Msg 82 Unknown
80 INVITE_GROUPCHAT :: Msg 95 Invite
81 INVITE_CONFERENCE :: Msg 96 Unknown
82 ONLINE_PACKET :: Msg 97 Unknown
83 DIRECT_CONFERENCE :: Msg 98 Unknown
84 MESSAGE_CONFERENCE :: Msg 99 Unknown
85 LOSSY_CONFERENCE :: Msg 199 Unknown
86
87deriving instance Show (Msg n a)
88
89msgbyte :: KnownNat n => Msg n a -> Word8
90msgbyte m = fromIntegral (natVal $ proxy m)
91 where proxy :: Msg n a -> Proxy n
92 proxy _ = Proxy
93
94data Pkt a where Pkt :: (KnownNat n, Packet a, KnownMsg n) => Msg n a -> Pkt a
95
96deriving instance (Show (Pkt a))
97
98type CryptoMessage = DSum Pkt Identity
99
100msgID (Pkt mid :=> Identity _) = M mid
101
102-- TODO
103instance GShow Pkt where gshowsPrec = showsPrec
104instance ShowTag Pkt Identity where
105 showTaggedPrec (Pkt _) = showsPrec
106
107instance GEq Pkt where geq (Pkt _) (Pkt _) = eqT
108instance EqTag Pkt Identity where eqTagged (Pkt _) (Pkt _) = (==)
109
110someMsgVal :: KnownMsg n => Msg n a -> SomeMsg
111someMsgVal m = msgid (proxy m)
112 where proxy :: Msg n a -> Proxy n
113 proxy _ = Proxy
114
115class KnownMsg (n::Nat) where msgid :: proxy n -> SomeMsg
116
117instance KnownMsg 0 where msgid _ = M Padding
118instance KnownMsg 1 where msgid _ = M PacketRequest
119instance KnownMsg 2 where msgid _ = M KillPacket
120instance KnownMsg 16 where msgid _ = M ALIVE
121instance KnownMsg 17 where msgid _ = M SHARE_RELAYS
122instance KnownMsg 18 where msgid _ = M FRIEND_REQUESTS
123instance KnownMsg 24 where msgid _ = M ONLINE
124instance KnownMsg 25 where msgid _ = M OFFLINE
125instance KnownMsg 48 where msgid _ = M NICKNAME
126instance KnownMsg 49 where msgid _ = M STATUSMESSAGE
127instance KnownMsg 50 where msgid _ = M USERSTATUS
128instance KnownMsg 51 where msgid _ = M TYPING
129instance KnownMsg 64 where msgid _ = M MESSAGE
130instance KnownMsg 65 where msgid _ = M ACTION
131instance KnownMsg 69 where msgid _ = M MSI
132instance KnownMsg 80 where msgid _ = M FILE_SENDREQUEST
133instance KnownMsg 81 where msgid _ = M FILE_CONTROL
134instance KnownMsg 82 where msgid _ = M FILE_DATA
135instance KnownMsg 95 where msgid _ = M INVITE_GROUPCHAT
136instance KnownMsg 96 where msgid _ = M INVITE_CONFERENCE
137instance KnownMsg 97 where msgid _ = M ONLINE_PACKET
138instance KnownMsg 98 where msgid _ = M DIRECT_CONFERENCE
139instance KnownMsg 99 where msgid _ = M MESSAGE_CONFERENCE
140
141msgTag :: Word8 -> Maybe SomeMsg
142msgTag 0 = Just $ M Padding
143msgTag 1 = Just $ M PacketRequest
144msgTag 2 = Just $ M KillPacket
145msgTag 16 = Just $ M ALIVE
146msgTag 17 = Just $ M SHARE_RELAYS
147msgTag 18 = Just $ M FRIEND_REQUESTS
148msgTag 24 = Just $ M ONLINE
149msgTag 25 = Just $ M OFFLINE
150msgTag 48 = Just $ M NICKNAME
151msgTag 49 = Just $ M STATUSMESSAGE
152msgTag 50 = Just $ M USERSTATUS
153msgTag 51 = Just $ M TYPING
154msgTag 64 = Just $ M MESSAGE
155msgTag 65 = Just $ M ACTION
156msgTag 69 = Just $ M MSI
157msgTag 80 = Just $ M FILE_SENDREQUEST
158msgTag 81 = Just $ M FILE_CONTROL
159msgTag 82 = Just $ M FILE_DATA
160msgTag 95 = Just $ M INVITE_GROUPCHAT
161msgTag 96 = Just $ M INVITE_CONFERENCE
162msgTag 97 = Just $ M ONLINE_PACKET
163msgTag 98 = Just $ M DIRECT_CONFERENCE
164msgTag 99 = Just $ M MESSAGE_CONFERENCE
165msgTag _ = Nothing
166
167
168class (Typeable t, Eq t, Show t, Sized t) => Packet t where
169 getPacket :: Word32 -> Get t
170 putPacket :: Word32 -> t -> Put
171 default getPacket :: Serialize t => Word32 -> Get t
172 getPacket _ = get
173 default putPacket :: Serialize t => Word32 -> t -> Put
174 putPacket _ t = put t
175
176instance Sized UserStatus where size = ConstSize 1
177instance Packet UserStatus
178
179instance Sized () where size = ConstSize 0
180instance Packet () where
181 getPacket _ = return ()
182 putPacket _ _ = return ()
183
184instance Sized MissingPackets where size = VarSize $ \(MissingPackets ws) -> Prelude.length ws
185instance Packet MissingPackets where
186 getPacket seqno = do
187 bs <- B.unpack <$> (remaining >>= getBytes)
188 return $ MissingPackets (decompressSequenceNumbers seqno bs)
189 putPacket seqno (MissingPackets ws) = do
190 mapM_ putWord8 $ compressSequenceNumbers seqno ws
191
192instance Sized Unknown where size = VarSize $ \(Unknown bs) -> B.length bs
193instance Packet Unknown where
194 getPacket _ = Unknown <$> (remaining >>= getBytes)
195 putPacket _ (Unknown bs) = putByteString bs
196
197instance Sized Padded where size = VarSize $ \(Padded bs) -> B.length bs
198instance Packet Padded where
199 getPacket _ = Padded <$> (remaining >>= getBytes)
200 putPacket _ (Padded bs) = putByteString bs
201
202instance Sized Text where size = VarSize (B.length . T.encodeUtf8)
203instance Packet Text where
204 getPacket _ = T.decodeUtf8 <$> (remaining >>= getBytes)
205 putPacket _ = putByteString . T.encodeUtf8
206
207instance Sized Bool where size = ConstSize 1
208instance Packet Bool where
209 getPacket _ = (/= 0) <$> getWord8
210 putPacket _ False = putWord8 0
211 putPacket _ True = putWord8 1
212
213data SomeMsg where
214 M :: (KnownMsg n, KnownNat n, Packet t) => Msg n t -> SomeMsg
215
216instance Eq SomeMsg where
217 M m == M n = msgbyte m == msgbyte n
218
219instance Show SomeMsg where
220 show (M m) = show m
221
222toEnum8 :: (Enum a, Integral word8) => word8 -> a
223toEnum8 = toEnum . fromIntegral
224
225fromEnum8 :: Enum a => a -> Word8
226fromEnum8 = fromIntegral . fromEnum
227
228data LossyOrLossless = Lossless | Lossy deriving (Eq,Ord,Enum,Show,Bounded)
229
230someLossyness (M m) = lossyness m
231
232lossyness :: KnownNat n => Msg n t -> LossyOrLossless
233lossyness m = case msgbyte m of
234 x | x < 3 -> Lossy
235 | {-16 <= x,-} x < 192 -> Lossless
236 | 192 <= x, x < 255 -> Lossy
237 | otherwise -> Lossless
238
239
240newtype ChatID = ChatID Ed25519.PublicKey
241 deriving Eq
242
243instance Sized ChatID where size = ConstSize 32
244
245instance Serialize ChatID where
246 get = do
247 bs <- getBytes 32
248 case Ed25519.publicKey bs of
249 CryptoPassed ed -> return $ ChatID ed
250 CryptoFailed e -> fail (show e)
251 put (ChatID ed) = putByteString $ BA.convert ed
252
253instance Read ChatID where
254 readsPrec _ s
255 | Right bs <- parseToken32 s
256 , CryptoPassed ed <- Ed25519.publicKey bs
257 = [ (ChatID ed, Prelude.drop 43 s) ]
258 | otherwise = []
259
260instance Show ChatID where
261 show (ChatID ed) = showToken32 ed
262
263data InviteType = GroupInvite { groupName :: Text }
264 | AcceptedInvite
265 | ConfirmedInvite { inviteNodes :: [NodeInfo] }
266 deriving (Eq,Show)
267
268instance Sized InviteType where
269 size = VarSize $ \x -> case x of
270 GroupInvite name -> B.length (T.encodeUtf8 name)
271 AcceptedInvite -> 0
272 ConfirmedInvite ns -> 0 -- TODO: size of node list.
273
274data Invite = Invite
275 { inviteChatID :: ChatID
276 , inviteChatKey :: PublicKey
277 , invite :: InviteType
278 }
279 deriving (Eq,Show)
280
281instance Sized Invite where
282 size = contramap inviteChatID size
283 <> contramap (key2id . inviteChatKey) size
284 <> contramap invite size
285
286instance Serialize Invite where
287 get = do
288 group_packet_id <- getWord8 -- expecting 254=GP_FRIEND_INVITE
289 invite_type <- getWord8
290 chatid <- get
291 chatkey <- getPublicKey
292 Invite chatid chatkey <$> case invite_type of
293 0 -> do bs <- remaining >>= getBytes -- TODO: size can be determined from group shared state.
294 return $ GroupInvite $ decodeUtf8 bs
295 1 -> return AcceptedInvite
296 2 -> return $ ConfirmedInvite [] -- TODO: decode nodes
297
298 put x = do
299 putWord8 254 -- GP_FRIEND_INVITE
300 putWord8 $ case invite x of
301 GroupInvite {} -> 0 -- GROUP_INVITE
302 AcceptedInvite -> 1 -- GROUP_INVITE_ACCEPTED
303 ConfirmedInvite {} -> 2 -- GROUP_INVITE_CONFIRMATION
304 put $ inviteChatID x
305 putPublicKey $ inviteChatKey x
306 case invite x of
307 GroupInvite name -> putByteString $ encodeUtf8 name
308 AcceptedInvite -> return ()
309 ConfirmedInvite ns -> return () -- TODO: encode nodes.
310
311instance Packet Invite where
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 23:11:11 +0000