summaryrefslogtreecommitdiff
path: root/dht/src/Network/Tox/Crypto/Transport.hs
diff options
context:
space:
mode:
authorJames Crayne <jim.crayne@gmail.com>2019-09-28 13:43:29 -0400
committerJoe Crayne <joe@jerkface.net>2020-01-01 19:27:53 -0500
commit11987749fc6e6d3e53ea737d46d5ab13a16faeb8 (patch)
tree5716463275c2d3e902889db619908ded2a73971c /dht/src/Network/Tox/Crypto/Transport.hs
parentadd2c76bced51fde5e9917e7449ef52be70faf87 (diff)
Factor out some new libraries
word64-map: Data.Word64Map network-addr: Network.Address tox-crypto: Crypto.Tox lifted-concurrent: Control.Concurrent.Lifted.Instrument Control.Concurrent.Async.Lifted.Instrument psq-wrap: Data.Wrapper.PSQInt Data.Wrapper.PSQ minmax-psq: Data.MinMaxPSQ tasks: Control.Concurrent.Tasks kad: Network.Kademlia Network.Kademlia.Bootstrap Network.Kademlia.Routing Network.Kademlia.CommonAPI Network.Kademlia.Persistence Network.Kademlia.Search
Diffstat (limited to 'dht/src/Network/Tox/Crypto/Transport.hs')
-rw-r--r--dht/src/Network/Tox/Crypto/Transport.hs1029
1 files changed, 1029 insertions, 0 deletions
diff --git a/dht/src/Network/Tox/Crypto/Transport.hs b/dht/src/Network/Tox/Crypto/Transport.hs
new file mode 100644
index 00000000..a18b550d
--- /dev/null
+++ b/dht/src/Network/Tox/Crypto/Transport.hs
@@ -0,0 +1,1029 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE KindSignatures #-}
6{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE NamedFieldPuns #-}
8{-# LANGUAGE PatternSynonyms #-}
9{-# LANGUAGE StandaloneDeriving #-}
10{-# LANGUAGE TupleSections #-}
11{-# LANGUAGE ViewPatterns #-}
12module Network.Tox.Crypto.Transport
13 ( showCryptoMsg
14 , parseCrypto
15 , encodeCrypto
16 , unpadCryptoMsg
17 , decodeRawCryptoMsg
18 , parseHandshakes
19 , encodeHandshakes
20 , CryptoData(..)
21 , CryptoMessage(..)
22 , MessageName(..)
23 , CryptoPacket(..)
24 , HandshakeData(..)
25 , Handshake(..)
26 , PeerInfo(..)
27 , UserStatus(..)
28 , TypingStatus(..)
29 , GroupChatId(..)
30 , MessageType(..)
31 , isKillPacket, isOFFLINE
32 , KnownLossyness(..)
33 , AsWord16(..)
34 , AsWord64(..)
35 -- feild name classes
36 , HasGroupChatID(..)
37 , HasGroupNumber(..)
38 , HasPeerNumber(..)
39 , HasMessageNumber(..)
40 , HasMessageName(..)
41 , HasMessageData(..)
42 , HasName(..)
43 , HasTitle(..)
44 , HasMessage(..)
45 , HasMessageType(..)
46 -- lenses
47#ifdef USE_lens
48 , groupNumber, groupNumberToJoin, peerNumber, messageNumber
49 , messageName, messageData, name, title, message, messageType
50#endif
51 -- constructor
52 -- utils
53 , sizedN
54 , sizedAtLeastN
55 , isIndirectGrpChat
56 , fromEnum8
57 , fromEnum16
58 , toEnum8
59 , getCryptoMessage
60 , putCryptoMessage
61 ) where
62
63import Crypto.Tox
64import Data.Tox.Msg
65import Network.Tox.DHT.Transport (Cookie)
66import Network.Tox.NodeId
67import DPut
68import DebugTag
69import Data.PacketBuffer as PB
70
71import Network.Socket
72import Data.ByteArray
73import Data.Dependent.Sum
74
75import Control.Monad
76import Data.ByteString as B
77import Data.Function
78import Data.Maybe
79import Data.Monoid
80import Data.Word
81import Data.Bits
82import Crypto.Hash
83import Data.Functor.Contravariant
84import Data.Functor.Identity
85import Data.Text as T
86import Data.Text.Encoding as T
87import Data.Serialize as S
88import Control.Arrow
89import GHC.TypeNats
90
91showCryptoMsg :: Word32 -> CryptoMessage -> [Char]
92showCryptoMsg _ msg = show msg
93
94parseCrypto :: (ByteString, SockAddr) -> Either (CryptoPacket Encrypted, SockAddr) (ByteString, SockAddr)
95parseCrypto (bbs,saddr) = case B.uncons bbs of
96 Just (0x1b,bs) -> case runGet get bs of
97 Right pkt -> Left (pkt, saddr) -- Successful parse, handle this packet.
98 Left _ -> Right (bs,saddr) -- Failed parse, strip first byte and pass it on.
99 _ -> Right (bbs,saddr) -- Type-code mismatch, pass it on.
100
101encodeCrypto :: (CryptoPacket Encrypted, SockAddr) -> Maybe (ByteString, SockAddr)
102encodeCrypto (x,saddr) = Just (B.cons 0x1b (runPut $ put x),saddr)
103
104parseHandshakes :: ByteString -> SockAddr -> Either String (Handshake Encrypted, SockAddr)
105parseHandshakes (B.uncons -> Just (0x1a,pkt)) saddr = left ("parseHandshakes: "++) $ (,saddr) <$> runGet get pkt
106parseHandshakes bs _ = Left $ "parseHandshakes_: " ++ show (B.unpack $ B.take 1 bs)
107
108encodeHandshakes :: Handshake Encrypted -> SockAddr -> (ByteString, SockAddr)
109encodeHandshakes x saddr = (B.cons 0x1a (runPut $ put x),saddr)
110
111{-
112createRequestPacket :: Word32 -> [Word32] -> CryptoMessage
113createRequestPacket seqno xs = let r = UpToN PacketRequest (B.pack ns)
114 in dtrace XNetCrypto ("createRequestPacket " ++ show seqno ++ " " ++ show xs ++ " -----> " ++ show r) r
115 where
116 ys = Prelude.map (subtract (seqno - 1)) xs
117 reduceToSums [] = []
118 reduceToSums (x:xs) = x:(reduceToSums $ Prelude.map (subtract x) xs)
119 makeZeroes :: Word32 -> [Word32]
120 -- makeZeroes 0 = []
121 makeZeroes x
122 = let (d,m)= x `divMod` 255
123 zeros= Prelude.replicate (fromIntegral d) 0
124 in zeros ++ [m]
125 ns :: [Word8]
126 ns = Prelude.map fromIntegral (reduceToSums ys >>= makeZeroes)
127-}
128
129data Handshake (f :: * -> *) = Handshake
130 { -- The cookie is a cookie obtained by
131 -- sending a cookie request packet to the peer and getting a cookie
132 -- response packet with a cookie in it. It may also be obtained in the
133 -- handshake packet by a peer receiving a handshake packet (Other
134 -- Cookie).
135 handshakeCookie :: Cookie f
136 -- The nonce is a nonce used to encrypt the encrypted part of the handshake
137 -- packet.
138 , handshakeNonce :: Nonce24
139 -- The encrypted part of the handshake packet is encrypted with the long
140 -- term user-keys of both peers.
141 , handshakeData :: f HandshakeData
142 }
143
144instance Serialize (Handshake Encrypted) where
145 get = Handshake <$> get <*> get <*> get
146 put (Handshake cookie n24 dta) = put cookie >> put n24 >> put dta
147
148data HandshakeData = HandshakeData
149 { baseNonce :: Nonce24
150 -- ^ 24 bytes base nonce, recipient uses this to encrypt packets sent to the one who sent this handshake
151 -- adding one each time, so it can double as something like an approximate packet number
152 , sessionKey :: PublicKey
153 -- ^ session public key of the peer (32 bytes)
154 -- The recipient of the handshake encrypts using this public key when sending CryptoPackets
155 , cookieHash :: Digest SHA512
156 -- ^ sha512 hash of the entire Cookie sitting outside the encrypted part
157 -- This prevents a replay attack where a new cookie is inserted into
158 -- an old valid handshake packet
159 , otherCookie :: Cookie Encrypted
160 -- ^ Other Cookie (used by the recipient to respond to the handshake packet)
161 }
162 deriving (Eq,Ord,Show)
163
164instance Sized HandshakeData where
165 size = contramap baseNonce size
166 <> contramap (key2id . sessionKey) size
167 <> ConstSize 64 -- contramap cookieHash size -- missing instance Sized (Digest SHA512)
168 <> contramap otherCookie size
169
170instance Serialize HandshakeData where
171 get = HandshakeData <$> get
172 <*> getPublicKey
173 <*> (fromJust . digestFromByteString <$> getBytes 64)
174 <*> get
175 put (HandshakeData n k h c) = do
176 put n
177 putPublicKey k
178 putByteString (convert h)
179 put c
180
181data CryptoPacket (f :: * -> *) = CryptoPacket
182 { -- | The last 2 bytes of the nonce used to encrypt 'pktData'
183 pktNonce :: Word16
184 -- The payload is encrypted with the session key and 'baseNonce' set by
185 -- the receiver in their handshake + packet number (starting at 0, big
186 -- endian math).
187 , pktData :: f CryptoData
188 }
189
190deriving instance Show (CryptoPacket Encrypted)
191
192instance Sized CryptoData where
193 size = contramap bufferStart size
194 <> contramap bufferEnd size
195 <> contramap bufferData size
196
197instance Serialize (CryptoPacket Encrypted) where
198 get = CryptoPacket <$> get <*> get
199 put (CryptoPacket n16 dta) = put n16 >> put dta
200
201data CryptoData = CryptoData
202 { -- | [our recvbuffers buffer_start, (highest packet number handled + 1), (big endian)]
203 bufferStart :: Word32
204 -- | [ uint32_t packet number if lossless
205 -- , sendbuffer buffer_end if lossy , (big endian)]
206 , bufferEnd :: Word32
207 -- | [data] (TODO See Note [Padding])
208 , bufferData :: CryptoMessage
209 } deriving (Eq,Show)
210
211{-
212Note [Padding]
213
214TODO: The 'bufferData' field of 'CryptoData' should probably be something like
215/Padded CryptoMessage/ because c-toxcore strips leading zeros on incoming and
216pads leading zeros on outgoing packets.
217
218After studying c-toxcore (at commit c49a6e7f5bc245a51a3c85cc2c8b7f881c412998),
219I've determined the following behavior.
220
221Incoming: All leading zero bytes are stripped until possibly the whole packet
222is consumed (in which case it is discarded). This happens at
223toxcore/net_crypto.c:1366:handle_data_packet_core().
224
225Outgoing: The number of zeros added is:
226
227 padding_length len = (1373 - len) `mod` 8 where
228
229where /len/ is the size of the non-padded CryptoMessage. This happens at
230toxcore/net_crypto.c:936:send_data_packet_helper()
231
232The number 1373 is written in C as MAX_CRYPTO_DATA_SIZE which is defined in
233terms of the max /NetCrypto/ packet size (1400) minus the minimum possible size
234of an id-byte (1) and a /CryptoPacket Encrypted/ ( 2 + 4 + 4 + 16 ).
235
236One effect of this is that short messages will be padded to at least 5 bytes.
237-}
238
239instance Serialize CryptoData where
240 get = do
241 ack <- get
242 seqno <- get
243 cm <- getCryptoMessage ack
244 return $ CryptoData ack seqno cm
245 put (CryptoData ack seqno dta) = do
246 put ack
247 put seqno
248 putCryptoMessage ack dta
249
250data TypingStatus = NotTyping | Typing deriving (Show,Read,Eq,Ord,Enum)
251instance Serialize TypingStatus where
252 get = do
253 x <- get :: Get Word8
254 return (toEnum8 x)
255 put x = put (fromEnum8 x :: Word8)
256
257unpadCryptoMsg :: CryptoMessage -> CryptoMessage
258unpadCryptoMsg msg@(Pkt Padding :=> Identity (Padded bs)) =
259 let unpadded = B.dropWhile (== msgbyte Padding) bs
260 in either (const msg) id $ runGet (getCryptoMessage 0) unpadded
261unpadCryptoMsg msg = msg
262
263decodeRawCryptoMsg :: CryptoData -> CryptoMessage
264decodeRawCryptoMsg (CryptoData ack seqno cm) = unpadCryptoMsg cm
265
266instance Sized CryptoMessage where
267 size = VarSize $ \case
268 Pkt t :=> Identity x -> case sizeFor t of
269 ConstSize sz -> 1 + sz
270 VarSize f -> 1 + f x
271
272sizeFor :: Sized x => p x -> Size x
273sizeFor _ = size
274
275
276getCryptoMessage :: Word32 -> Get CryptoMessage
277getCryptoMessage seqno = fix $ \stripPadding -> do
278 t <- getWord8
279 case msgTag t of
280 Just (M Padding) -> stripPadding
281 Just (M msg) -> do x <- getPacket seqno
282 return $ Pkt msg ==> x
283 Nothing -> return $ Pkt MESSAGE ==> "Unhandled packet: " <> T.pack (show t) -- $ Pkt Padding ==> Padded mempty
284
285putCryptoMessage :: Word32 -> CryptoMessage -> Put
286putCryptoMessage seqno (Pkt t :=> Identity x) = do
287 putWord8 (msgbyte t)
288 putPacket seqno x
289
290
291#ifdef USE_lens
292erCompat :: String -> a
293erCompat lens = error $ "Use of '" ++ lens ++ "' lens on incompatible CryptoMessage type"
294#endif
295
296
297newtype GroupChatId = GrpId ByteString -- 33 bytes
298 deriving (Show,Eq)
299
300class HasGroupChatID x where
301 getGroupChatID :: x -> GroupChatId
302 setGroupChatID :: x -> GroupChatId -> x
303
304sizedN :: Int -> ByteString -> ByteString
305sizedN n bs = if B.length bs < n then B.append bs (B.replicate (n - B.length bs) 0)
306 else B.take n bs
307
308sizedAtLeastN :: Int -> ByteString -> ByteString
309sizedAtLeastN n bs = if B.length bs < n then B.append bs (B.replicate (n - B.length bs) 0)
310 else bs
311
312{-
313instance HasGroupChatID CryptoMessage where
314 -- Get
315 getGroupChatID (Pkt INVITE_CONFERENCE :=> Identity payload)
316 = let (xs,ys) = B.splitAt 1 payload'
317 payload' = sizedN 38 payload
318 in case B.unpack xs of
319 [isResponse] | 0 <- isResponse -> GrpId (B.take 33 $ B.drop 2 ys) -- skip group number
320 [isResponse] | 1 <- isResponse -> GrpId (B.take 33 $ B.drop 4 ys) -- skip two group numbers
321 _ -> GrpId "" -- error "Unexpected value in INVITE_GROUPCHAT message"
322
323 getGroupChatID (Pkt ONLINE_PACKET :=> Identity payload) = GrpId (B.take 33 $ B.drop 2 (sizedN 35 payload))
324 getGroupChatID _ = error "getGroupChatID on non-groupchat message."
325
326 -- Set
327 setGroupChatID msg@(Pkt INVITE_CONFERENCE :=> Identity payload) (GrpId newid)
328 = let (xs,ys) = B.splitAt 1 payload'
329 payload' = sizedN 38 payload
330 in case B.unpack xs of
331 [isResponse] | 0 <- isResponse -> UpToN INVITE_GROUPCHAT (B.concat [xs, (B.take 2 ys), sizedN 33 newid]) -- keep group number
332 [isResponse] | 1 <- isResponse -> UpToN INVITE_GROUPCHAT (B.concat [xs, (B.take 4 ys), sizedN 33 newid]) -- keep two group numbers
333 _ -> msg -- unexpected condition, leave unchanged
334
335 setGroupChatID (Pkt ONLINE_PACKET :=> Identity payload) (GrpId newid) = Pkt ONLINE_PACKET ==> (B.concat [B.take 2 payload, sizedN 33 newid])
336 setGroupChatID _ _= error "setGroupChatID on non-groupchat message."
337-}
338
339#ifdef USE_lens
340groupChatID :: (Functor f, HasGroupChatID x) => (GroupChatId -> f GroupChatId) -> (x -> f x)
341groupChatID = lens getGroupChatID setGroupChatID
342#endif
343
344type GroupNumber = Word16
345type PeerNumber = Word16
346type MessageNumber = Word32
347
348class HasGroupNumber x where
349 getGroupNumber :: x -> GroupNumber
350 setGroupNumber :: x -> GroupNumber -> x
351
352{-
353instance HasGroupNumber CryptoMessage where
354 getGroupNumber (Pkt INVITE_CONFERENCE :=> Identity (sizedN 39 -> B.uncons -> Just (isResp,xs))) -- note isResp should be 0 or 1
355 = let twobytes = B.take 2 xs
356 Right n = S.decode twobytes
357 in n
358 getGroupNumber (UpToN (fromEnum -> x) (sizedN 2 -> twobytes)) | x >= 0x61 && x <= 0x63
359 = let Right n = S.decode twobytes in n
360 getGroupNumber (UpToN (fromEnum -> 0xC7) (sizedN 2 -> twobytes))
361 = let Right n = S.decode twobytes in n
362
363 getGroupNumber _ = error "getGroupNumber on CryptoMessage without group number field."
364
365 setGroupNumber (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (isResp,xs))) groupnum
366 = UpToN INVITE_GROUPCHAT (B.cons isResp (B.append (S.encode groupnum) (B.drop 2 xs)))
367 setGroupNumber (UpToN xE@(fromEnum -> x) (sizedAtLeastN 2 -> B.splitAt 2 -> (twobytes,xs))) groupnum
368 | x >= 0x61 && x <= 0x63 = UpToN xE (B.append (S.encode groupnum) xs)
369 | x == 0xC7 = UpToN xE (B.append (S.encode groupnum) xs)
370 setGroupNumber _ _ = error "setGroupNumber on CryptoMessage without group number field."
371-}
372
373#ifdef USE_lens
374groupNumber :: (Functor f, HasGroupNumber x) => (Word16 -> f Word16) -> (x -> f x)
375groupNumber = lens getGroupNumber setGroupNumber
376#endif
377
378class HasGroupNumberToJoin x where
379 getGroupNumberToJoin :: x -> GroupNumber
380 setGroupNumberToJoin :: x -> GroupNumber -> x
381
382{-
383instance HasGroupNumberToJoin CryptoMessage where
384 getGroupNumberToJoin (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (1,xs))) -- only response has to-join
385 = let twobytes = B.take 2 (B.drop 2 xs) -- skip group number (local)
386 Right n = S.decode twobytes
387 in n
388 getGroupNumberToJoin _ = error "getGroupNumberToJoin on CryptoMessage without group number (to join) field."
389 setGroupNumberToJoin (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (1,xs))) groupnum
390 = let (a,b) = B.splitAt 2 xs
391 (twoBytes,c) = B.splitAt 2 b
392 twoBytes' = S.encode groupnum
393 in UpToN INVITE_GROUPCHAT (B.cons 1 (B.concat [a,twoBytes',c]))
394 setGroupNumberToJoin _ _ = error "setGroupNumberToJoin on CryptoMessage without group number (to join) field."
395-}
396
397#ifdef USE_lens
398groupNumberToJoin :: (Functor f, HasGroupNumberToJoin x) => (GroupNumber -> f GroupNumber) -> (x -> f x)
399groupNumberToJoin = lens getGroupNumberToJoin setGroupNumberToJoin
400#endif
401
402class HasPeerNumber x where
403 getPeerNumber :: x -> PeerNumber
404 setPeerNumber :: x -> PeerNumber -> x
405
406{-
407instance HasPeerNumber CryptoMessage where
408 getPeerNumber (UpToN (fromEnum -> 0x63) (sizedN 4 -> B.splitAt 2 -> (grpnum,twobytes)))
409 = let Right n = S.decode twobytes in n
410 getPeerNumber (UpToN (fromEnum -> 0xC7) (sizedN 4 -> B.splitAt 2 -> (grpnum,twobytes)))
411 = let Right n = S.decode twobytes in n
412 getPeerNumber _ = error "getPeerNumber on CryptoMessage without peer number field."
413
414 setPeerNumber (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 4 -> B.splitAt 2 -> (gnum,xs))) peernum
415 = UpToN xE (B.concat [gnum,S.encode peernum, B.drop 2 xs])
416 setPeerNumber (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 4 -> B.splitAt 2 -> (gnum,xs))) peernum
417 = UpToN xE (B.concat [gnum,S.encode peernum, B.drop 2 xs])
418 setPeerNumber _ _ = error "setPeerNumber on CryptoMessage without peer number field."
419-}
420
421#ifdef USE_lens
422peerNumber :: (Functor f, HasPeerNumber x) => (Word16 -> f Word16) -> (x -> f x)
423peerNumber = lens getPeerNumber setPeerNumber
424#endif
425
426class HasMessageNumber x where
427 getMessageNumber :: x -> MessageNumber
428 setMessageNumber :: x -> MessageNumber -> x
429
430{-
431instance HasMessageNumber CryptoMessage where
432 getMessageNumber (UpToN (fromEnum -> 0x63) (sizedN 8 -> B.splitAt 4 -> (_,fourbytes)))
433 = let Right n = S.decode fourbytes in n
434 getMessageNumber (UpToN (fromEnum -> 0xC7) (sizedN 8 -> B.splitAt 4 -> (_,fourbytes)))
435 = let Right n = S.decode fourbytes in n
436 getMessageNumber _ = error "getMessageNumber on CryptoMessage without message number field."
437
438 setMessageNumber (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 8 -> B.splitAt 4 -> (bs,xs))) messagenum
439 = UpToN xE (B.concat [bs,S.encode messagenum, B.drop 4 xs])
440 setMessageNumber (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 8 -> B.splitAt 4 -> (bs,xs))) messagenum
441 = UpToN xE (B.concat [bs,S.encode messagenum, B.drop 4 xs])
442 setMessageNumber _ _ = error "setMessageNumber on CryptoMessage without message number field."
443-}
444
445#ifdef USE_lens
446messageNumber :: (Functor f, HasMessageNumber x) => (Word32 -> f Word32) -> (x -> f x)
447messageNumber = lens getMessageNumber setMessageNumber
448#endif
449
450class HasMessageName x where
451 getMessageName :: x -> MessageName
452 setMessageName :: x -> MessageName -> x
453
454{-
455instance HasMessageName CryptoMessage where
456 getMessageName (UpToN (fromEnum -> 0x63) (sizedN 9 -> B.splitAt 8 -> (_,onebyte)))
457 = let [n] = B.unpack onebyte
458 in toEnum . fromIntegral $ n
459 getMessageName (UpToN (fromEnum -> 0xC7) (sizedN 9 -> B.splitAt 8 -> (_,onebyte)))
460 = let [n] = B.unpack onebyte
461 in toEnum . fromIntegral $ n
462 getMessageName _ = error "getMessageName on CryptoMessage without message name field."
463
464 setMessageName (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,xs))) messagename
465 = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum messagename) (B.drop 1 xs)])
466 setMessageName (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,xs))) messagename
467 = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum messagename) (B.drop 1 xs)])
468 setMessageName _ _ = error "setMessageName on CryptoMessage without message name field."
469-}
470
471#ifdef USE_lens
472messageName :: (Functor f, HasMessageName x) => (MessageName -> f MessageName) -> (x -> f x)
473messageName = lens getMessageName setMessageName
474#endif
475
476data KnownLossyness = KnownLossy | KnownLossless
477 deriving (Eq,Ord,Show,Enum)
478
479data MessageType = Msg Word8
480 | GrpMsg KnownLossyness MessageName
481 deriving (Eq,Show)
482
483class AsWord16 a where
484 toWord16 :: a -> Word16
485 fromWord16 :: Word16 -> a
486
487class AsWord64 a where
488 toWord64 :: a -> Word64
489 fromWord64 :: Word64 -> a
490
491
492fromEnum16 :: Enum a => a -> Word16
493fromEnum16 = fromIntegral . fromEnum
494
495fromEnum64 :: Enum a => a -> Word64
496fromEnum64 = fromIntegral . fromEnum
497
498
499-- MessageType, for our client keep it inside 16 bits
500-- but we should extend it to 32 or even 64 on the wire.
501-- Bits: 000000glxxxxxxxx, x = message id or extension specific, l = if extended, lossy/lossless, g = if extended, nongroup/group
502-- (at least one bit set in high byte means extended, if none but the g flag and possibly l flag, assume default grp extension)
503instance AsWord16 MessageType where
504 toWord16 (Msg msgID) = fromIntegral (fromIntegral (fromEnum16 msgID) :: Word8)
505 toWord16 (GrpMsg lsy msgName) = 512 + 256 * (fromEnum16 lsy) + fromIntegral (fromEnum8 msgName)
506 fromWord16 x | x < 256 = Msg (toEnum $ fromIntegral x)
507 fromWord16 x | x < 1024, x .|. 0x0200 == 0x0200 = GrpMsg (toEnum8 ((x - 512) `div` 256)) (toEnum8 x)
508 fromWord16 x = error "Not clear how to convert Word16 to MessageType"
509
510instance AsWord64 MessageType where
511 toWord64 (Msg msgID) = fromIntegral (fromIntegral (fromEnum16 msgID) :: Word8)
512 toWord64 (GrpMsg lsy msgName) = 512 + 256 * (fromEnum64 lsy) + fromIntegral (fromEnum8 msgName)
513 fromWord64 x | x < 256 = Msg (toEnum $ fromIntegral x)
514 fromWord64 x | x < 1024, x .|. 0x0200 == 0x0200 = GrpMsg (toEnum8 ((x - 512) `div` 256)) (toEnum8 x)
515 fromWord64 x = error "Not clear how to convert Word64 to MessageType"
516
517#ifdef USE_lens
518word16 :: (Functor f, AsWord16 x) => (Word16 -> f Word16) -> (x -> f x)
519word16 = lens toWord16 (\_ x -> fromWord16 x)
520#endif
521
522instance Ord MessageType where
523 compare (Msg x) (Msg y) = compare x y
524 compare (GrpMsg lx x) (GrpMsg ly y) = let r1 = compare lx ly
525 in if r1==EQ then compare x y else r1
526 compare (Msg _) (GrpMsg _ _) = LT
527 compare (GrpMsg _ _) (Msg _) = GT
528
529class HasMessageType x where
530 getMessageType :: x -> MessageType
531 setMessageType :: x -> MessageType -> x
532
533{-
534instance HasMessageType CryptoMessage where
535 getMessageType (OneByte mid) = Msg mid
536 getMessageType (TwoByte mid _) = Msg mid
537 getMessageType m@(UpToN MESSAGE_GROUPCHAT _) = GrpMsg KnownLossless (getMessageName m)
538 getMessageType m@(UpToN LOSSY_GROUPCHAT _) = GrpMsg KnownLossy (getMessageName m)
539 getMessageType (UpToN mid _) = Msg mid
540
541 setMessageType (OneByte _ ) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT B.empty ) mname
542 setMessageType (TwoByte _ x) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT (B.singleton x)) mname
543 setMessageType (OneByte _ ) (GrpMsg KnownLossy mname) = setMessageName (UpToN LOSSY_GROUPCHAT B.empty ) mname
544 setMessageType (TwoByte _ x) (GrpMsg KnownLossy mname) = setMessageName (UpToN LOSSY_GROUPCHAT (B.singleton x)) mname
545 setMessageType (UpToN _ x) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT x) mname
546 setMessageType (UpToN _ x) (GrpMsg KnownLossy mname) = setMessageName (UpToN LOSSY_GROUPCHAT x) mname
547 setMessageType m (Msg mid) | Just (True,1) <- msgSizeParam mid = OneByte mid
548 setMessageType (OneByte mid0 ) (Msg mid) | Just (True,2) <- msgSizeParam mid = TwoByte mid 0
549 setMessageType (TwoByte mid0 x) (Msg mid) | Just (True,2) <- msgSizeParam mid = TwoByte mid x
550 setMessageType (UpToN mid0 x) (Msg mid) | Just (True,n) <- msgSizeParam mid = UpToN mid (sizedN n x)
551 setMessageType (OneByte mid0) (Msg mid) = UpToN mid B.empty
552 setMessageType (TwoByte mid0 x) (Msg mid) = UpToN mid (B.singleton x)
553 setMessageType (UpToN mid0 x) (Msg mid) = UpToN mid x
554-}
555
556{-
557instance HasMessageType CryptoData where
558 getMessageType (CryptoData { bufferData }) = getMessageType bufferData
559 setMessageType cd@(CryptoData { bufferData=bd }) typ = cd { bufferData=setMessageType bd typ }
560-}
561
562#ifdef USE_lens
563-- | This lens should always succeed on CryptoMessage
564messageType :: (Functor f, HasMessageType x) => (MessageType -> f MessageType) -> (x -> f x)
565messageType = lens getMessageType setMessageType
566#endif
567
568type MessageData = B.ByteString
569
570class HasMessageData x where
571 getMessageData :: x -> MessageData
572 setMessageData :: x -> MessageData -> x
573
574{-
575instance HasMessageData CryptoMessage where
576 getMessageData (UpToN (fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 9 -> (_,mdata))) = mdata
577 getMessageData (UpToN (fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 9 -> (_,mdata))) = mdata
578 getMessageData (UpToN (fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 2 -> (_,B.uncons -> Just (0x09,peerinfos)))) = peerinfos
579 -- getMessageData on 0x62:0a is equivalent to getTitle but without decoding the utf8
580 getMessageData (UpToN (fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 2 -> (_,B.uncons -> Just (0x0a,title)))) = title
581 getMessageData _ = error "getMessageData on CryptoMessage without message data field."
582
583 setMessageData (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 9 -> (bs,xs))) messagedata -- MESSAGE_GROUPCHAT
584 = UpToN xE (B.concat [bs,messagedata])
585 setMessageData (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 9 -> (bs,xs))) messagedata -- LOSSY_GROUPCHAT
586 = UpToN xE (B.concat [bs,messagedata])
587 setMessageData (UpToN xE@(fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 3 -> (bs,xs))) peerinfosOrTitle -- peer/title response packets
588 = UpToN xE (B.concat [bs,peerinfosOrTitle])
589 setMessageData _ _ = error "setMessageData on CryptoMessage without message data field."
590-}
591
592#ifdef USE_lens
593messageData :: (Functor f, HasMessageData x) => (MessageData -> f MessageData) -> (x -> f x)
594messageData = lens getMessageData setMessageData
595#endif
596
597class HasTitle x where
598 getTitle :: x -> Text
599 setTitle :: x -> Text -> x
600
601{-
602instance HasTitle CryptoMessage where
603 getTitle (UpToN xE bs)
604 | DIRECT_GROUPCHAT {-0x62-} <- xE,
605 (_,0x0a,mdata) <- splitByteAt 2 bs = decodeUtf8 mdata
606 | isIndirectGrpChat xE,
607 let (_,nmb,mdata) = splitByteAt 8 bs
608 nm = toEnum (fromIntegral nmb),
609 GroupchatTitleChange <- nm = decodeUtf8 mdata
610 getTitle _ = error "getTitle on CryptoMessage without title field."
611
612 setTitle (UpToN xE bs) msgdta
613 | DIRECT_GROUPCHAT {-0x62-} <- xE
614 = let (pre,_,_) = splitByteAt 2 bs
615 nm = 0x0a
616 in UpToN xE (pre <> B.cons nm (encodeUtf8 msgdta))
617 | isIndirectGrpChat xE
618 = let (pre,_,_) = splitByteAt 8 bs
619 nm = fromIntegral $ fromEnum GroupchatTitleChange
620 in UpToN xE (pre <> B.cons nm (encodeUtf8 msgdta))
621 setTitle _ _ = error "setTitle on CryptoMessage without title field."
622-}
623
624#ifdef USE_lens
625title :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x)
626title = lens getTitle setTitle
627#endif
628
629class HasMessage x where
630 getMessage :: x -> Text
631 setMessage :: x -> Text -> x
632
633splitByteAt :: Int -> ByteString -> (ByteString,Word8,ByteString)
634splitByteAt n bs = (fixed,w8,bs')
635 where
636 (fixed,B.uncons -> Just (w8,bs')) = B.splitAt n $ sizedAtLeastN (n+1) bs
637
638{-
639instance HasMessage CryptoMessage where
640 getMessage (UpToN xE bs)
641 | MESSAGE <- xE = T.decodeUtf8 bs
642 | isIndirectGrpChat xE = T.decodeUtf8 mdata where (_,_,mdata) = splitByteAt 8 bs
643 getMessage _ = error "getMessage on CryptoMessage without message field."
644
645 setMessage (UpToN xE bs) message
646 | MESSAGE <- xE
647 = UpToN xE $ T.encodeUtf8 message
648 | isIndirectGrpChat xE
649 = let (pre8,nm0,xs) = splitByteAt 8 bs
650 nm = if nm0 == 0 then 0x40 else nm0
651 prefix x = pre8 <> B.cons nm x
652 in UpToN xE $ prefix $ T.encodeUtf8 message
653 setMessage _ _ = error "setMessage on CryptoMessage without message field."
654-}
655
656#ifdef USE_lens
657message :: (Functor f, HasMessage x) => (Text -> f Text) -> (x -> f x)
658message = lens getMessage setMessage
659#endif
660
661class HasName x where
662 getName :: x -> Text
663 setName :: x -> Text -> x
664
665
666{-
667instance HasName CryptoMessage where
668 -- Only MESSAGE_GROUPCHAT:NameChange has Name field
669 getName (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (_,B.uncons -> Just (toEnum . fromIntegral -> NameChange,mdata)))) | isIndirectGrpChat xE = decodeUtf8 mdata
670 getName _ = error "getName on CryptoMessage without name field."
671
672 -- If its not NameChange, this setter will set it to NameChange
673 setName (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (bs,B.uncons -> Just (_,xs)))) name
674 | isIndirectGrpChat xE = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum NameChange) (encodeUtf8 name)])
675 setName _ _ = error "setName on CryptoMessage without name field."
676-}
677
678#ifdef USE_lens
679name :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x)
680name = lens getTitle setTitle
681#endif
682
683data PeerInfo
684 = PeerInfo
685 { piPeerNum :: PeerNumber
686 , piUserKey :: PublicKey
687 , piDHTKey :: PublicKey
688 , piName :: ByteString -- byte-prefix for length
689 } deriving (Eq,Show)
690
691instance HasPeerNumber PeerInfo where
692 getPeerNumber = piPeerNum
693 setPeerNumber x n = x { piPeerNum = n }
694
695instance Serialize PeerInfo where
696 get = do
697 w16 <- get
698 ukey <- getPublicKey
699 dkey <- getPublicKey
700 w8 <- get :: Get Word8
701 PeerInfo w16 ukey dkey <$> getBytes (fromIntegral w8)
702
703 put (PeerInfo w16 ukey dkey bs) = do
704 put w16
705 putPublicKey ukey
706 putPublicKey dkey
707 let sz :: Word8
708 sz = case B.length bs of
709 n | n <= 255 -> fromIntegral n
710 | otherwise -> 255
711 put sz
712 putByteString $ B.take (fromIntegral sz) bs
713
714
715{-
716-- |
717-- default constructor, handy for formations such as:
718--
719-- > userStatus .~ Busy $ msg USERSTATUS
720--
721msg :: MessageID -> CryptoMessage
722msg mid | Just (True,0) <- msgSizeParam mid = OneByte mid
723 | Just (True,1) <- msgSizeParam mid = TwoByte mid 0
724 | Just (False,_) <- msgSizeParam mid = UpToN mid B.empty
725 | otherwise = UpToN mid B.empty
726-}
727
728{-
729leaveMsg, peerQueryMsg :: Serialize a => a -> CryptoMessage
730leaveMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x01)
731peerQueryMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x08)
732-}
733
734{-
735-- | Returns if the given message is of fixed(OneByte/TwoByte) size, as well as
736-- the maximum allowed size for the message Payload (message minus id)
737-- Or Nothing if unknown/unimplemented.
738msgSizeParam :: MessageID -> Maybe (Bool,Int)
739msgSizeParam ONLINE = Just (True ,0)
740msgSizeParam OFFLINE = Just (True ,0)
741msgSizeParam USERSTATUS = Just (True ,1)
742msgSizeParam TYPING = Just (True ,1)
743msgSizeParam NICKNAME = Just (False,128)
744msgSizeParam STATUSMESSAGE = Just (False,1007)
745msgSizeParam MESSAGE = Just (False,1372)
746msgSizeParam ACTION = Just (False,1372)
747msgSizeParam FILE_DATA = Just (False,1372)-- up to 1373
748msgSizeParam FILE_SENDREQUEST = Just (False,300) -- 1+1+4+8+32+max255 = up to 301
749msgSizeParam FILE_CONTROL = Just (False,7) -- 8 bytes if seek, otherwise 4
750msgSizeParam INVITE_GROUPCHAT = Just (False,38)
751msgSizeParam ONLINE_PACKET = Just (True ,35)
752msgSizeParam DIRECT_GROUPCHAT {-0x62-} = Nothing -- 1+2+1 thus Just (True,3) leave & peer-query, but variable in response packets
753msgSizeParam MESSAGE_GROUPCHAT {-0x63-} = Nothing -- variable
754msgSizeParam LOSSY_GROUPCHAT {-0xC7-} = Nothing -- variable
755msgSizeParam _ = Nothing
756-}
757
758isIndirectGrpChat :: Msg n t -> Bool
759isIndirectGrpChat MESSAGE_CONFERENCE = True
760isIndirectGrpChat LOSSY_CONFERENCE = True
761isIndirectGrpChat _ = False
762
763isKillPacket :: SomeMsg -> Bool
764isKillPacket (M KillPacket) = True
765isKillPacket _ = False
766
767isOFFLINE :: SomeMsg -> Bool
768isOFFLINE (M OFFLINE) = True
769isOFFLINE _ = False
770
771
772data MessageName = Ping -- 0x00
773 | MessageName0x01
774 | MessageName0x02
775 | MessageName0x03
776 | MessageName0x04
777 | MessageName0x05
778 | MessageName0x06
779 | MessageName0x07
780 | MessageName0x08
781 | MessageName0x09
782 | MessageName0x0a
783 | MessageName0x0b
784 | MessageName0x0c
785 | MessageName0x0d
786 | MessageName0x0e
787 | MessageName0x0f
788 | NewPeer -- 0x10
789 | KillPeer -- 0x11
790 | MessageName0x12
791 | MessageName0x13
792 | MessageName0x14
793 | MessageName0x15
794 | MessageName0x16
795 | MessageName0x17
796 | MessageName0x18
797 | MessageName0x19
798 | MessageName0x1a
799 | MessageName0x1b
800 | MessageName0x1c
801 | MessageName0x1d
802 | MessageName0x1e
803 | MessageName0x1f
804 | MessageName0x20
805 | MessageName0x21
806 | MessageName0x22
807 | MessageName0x23
808 | MessageName0x24
809 | MessageName0x25
810 | MessageName0x26
811 | MessageName0x27
812 | MessageName0x28
813 | MessageName0x29
814 | MessageName0x2a
815 | MessageName0x2b
816 | MessageName0x2c
817 | MessageName0x2d
818 | MessageName0x2e
819 | MessageName0x2f
820 | NameChange -- 0x30
821 | GroupchatTitleChange -- 0x31
822 | MessageName0x32
823 | MessageName0x33
824 | MessageName0x34
825 | MessageName0x35
826 | MessageName0x36
827 | MessageName0x37
828 | MessageName0x38
829 | MessageName0x39
830 | MessageName0x3a
831 | MessageName0x3b
832 | MessageName0x3c
833 | MessageName0x3d
834 | MessageName0x3e
835 | MessageName0x3f
836 | ChatMessage -- 0x40
837 | Action -- 0x41
838 | MessageName0x42
839 | MessageName0x43
840 | MessageName0x44
841 | MessageName0x45
842 | MessageName0x46
843 | MessageName0x47
844 | MessageName0x48
845 | MessageName0x49
846 | MessageName0x4a
847 | MessageName0x4b
848 | MessageName0x4c
849 | MessageName0x4d
850 | MessageName0x4e
851 | MessageName0x4f
852 | MessageName0x50
853 | MessageName0x51
854 | MessageName0x52
855 | MessageName0x53
856 | MessageName0x54
857 | MessageName0x55
858 | MessageName0x56
859 | MessageName0x57
860 | MessageName0x58
861 | MessageName0x59
862 | MessageName0x5a
863 | MessageName0x5b
864 | MessageName0x5c
865 | MessageName0x5d
866 | MessageName0x5e
867 | MessageName0x5f
868 | MessageName0x60
869 | MessageName0x61
870 | MessageName0x62
871 | MessageName0x63
872 | MessageName0x64
873 | MessageName0x65
874 | MessageName0x66
875 | MessageName0x67
876 | MessageName0x68
877 | MessageName0x69
878 | MessageName0x6a
879 | MessageName0x6b
880 | MessageName0x6c
881 | MessageName0x6d
882 | MessageName0x6e
883 | MessageName0x6f
884 | MessageName0x70
885 | MessageName0x71
886 | MessageName0x72
887 | MessageName0x73
888 | MessageName0x74
889 | MessageName0x75
890 | MessageName0x76
891 | MessageName0x77
892 | MessageName0x78
893 | MessageName0x79
894 | MessageName0x7a
895 | MessageName0x7b
896 | MessageName0x7c
897 | MessageName0x7d
898 | MessageName0x7e
899 | MessageName0x7f
900 | MessageName0x80
901 | MessageName0x81
902 | MessageName0x82
903 | MessageName0x83
904 | MessageName0x84
905 | MessageName0x85
906 | MessageName0x86
907 | MessageName0x87
908 | MessageName0x88
909 | MessageName0x89
910 | MessageName0x8a
911 | MessageName0x8b
912 | MessageName0x8c
913 | MessageName0x8d
914 | MessageName0x8e
915 | MessageName0x8f
916 | MessageName0x90
917 | MessageName0x91
918 | MessageName0x92
919 | MessageName0x93
920 | MessageName0x94
921 | MessageName0x95
922 | MessageName0x96
923 | MessageName0x97
924 | MessageName0x98
925 | MessageName0x99
926 | MessageName0x9a
927 | MessageName0x9b
928 | MessageName0x9c
929 | MessageName0x9d
930 | MessageName0x9e
931 | MessageName0x9f
932 | MessageName0xa0
933 | MessageName0xa1
934 | MessageName0xa2
935 | MessageName0xa3
936 | MessageName0xa4
937 | MessageName0xa5
938 | MessageName0xa6
939 | MessageName0xa7
940 | MessageName0xa8
941 | MessageName0xa9
942 | MessageName0xaa
943 | MessageName0xab
944 | MessageName0xac
945 | MessageName0xad
946 | MessageName0xae
947 | MessageName0xaf
948 | MessageName0xb0
949 | MessageName0xb1
950 | MessageName0xb2
951 | MessageName0xb3
952 | MessageName0xb4
953 | MessageName0xb5
954 | MessageName0xb6
955 | MessageName0xb7
956 | MessageName0xb8
957 | MessageName0xb9
958 | MessageName0xba
959 | MessageName0xbb
960 | MessageName0xbc
961 | MessageName0xbd
962 | MessageName0xbe
963 | MessageName0xbf
964 | MessageName0xc0
965 | MessageName0xc1
966 | MessageName0xc2
967 | MessageName0xc3
968 | MessageName0xc4
969 | MessageName0xc5
970 | MessageName0xc6
971 | MessageName0xc7
972 | MessageName0xc8
973 | MessageName0xc9
974 | MessageName0xca
975 | MessageName0xcb
976 | MessageName0xcc
977 | MessageName0xcd
978 | MessageName0xce
979 | MessageName0xcf
980 | MessageName0xd0
981 | MessageName0xd1
982 | MessageName0xd2
983 | MessageName0xd3
984 | MessageName0xd4
985 | MessageName0xd5
986 | MessageName0xd6
987 | MessageName0xd7
988 | MessageName0xd8
989 | MessageName0xd9
990 | MessageName0xda
991 | MessageName0xdb
992 | MessageName0xdc
993 | MessageName0xdd
994 | MessageName0xde
995 | MessageName0xdf
996 | MessageName0xe0
997 | MessageName0xe1
998 | MessageName0xe2
999 | MessageName0xe3
1000 | MessageName0xe4
1001 | MessageName0xe5
1002 | MessageName0xe6
1003 | MessageName0xe7
1004 | MessageName0xe8
1005 | MessageName0xe9
1006 | MessageName0xea
1007 | MessageName0xeb
1008 | MessageName0xec
1009 | MessageName0xed
1010 | MessageName0xee
1011 | MessageName0xef
1012 | MessageName0xf0
1013 | MessageName0xf1
1014 | MessageName0xf2
1015 | MessageName0xf3
1016 | MessageName0xf4
1017 | MessageName0xf5
1018 | MessageName0xf6
1019 | MessageName0xf7
1020 | MessageName0xf8
1021 | MessageName0xf9
1022 | MessageName0xfa
1023 | MessageName0xfb
1024 | MessageName0xfc
1025 | MessageName0xfd
1026 | MessageName0xfe
1027 | MessageName0xff
1028 deriving (Show,Eq,Ord,Enum,Bounded)
1029
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-26 19:02:36 +0000