diff options
Diffstat (limited to 'src/Network/Tox/Crypto')
-rw-r--r-- | src/Network/Tox/Crypto/Transport.hs | 231 |
1 files changed, 79 insertions, 152 deletions
diff --git a/src/Network/Tox/Crypto/Transport.hs b/src/Network/Tox/Crypto/Transport.hs index b79334d7..d1afaa38 100644 --- a/src/Network/Tox/Crypto/Transport.hs +++ b/src/Network/Tox/Crypto/Transport.hs | |||
@@ -1,4 +1,6 @@ | |||
1 | {-# LANGUAGE DataKinds #-} | ||
1 | {-# LANGUAGE FlexibleInstances #-} | 2 | {-# LANGUAGE FlexibleInstances #-} |
3 | {-# LANGUAGE GADTs #-} | ||
2 | {-# LANGUAGE KindSignatures #-} | 4 | {-# LANGUAGE KindSignatures #-} |
3 | {-# LANGUAGE LambdaCase #-} | 5 | {-# LANGUAGE LambdaCase #-} |
4 | {-# LANGUAGE NamedFieldPuns #-} | 6 | {-# LANGUAGE NamedFieldPuns #-} |
@@ -12,7 +14,6 @@ module Network.Tox.Crypto.Transport | |||
12 | , encodeCrypto | 14 | , encodeCrypto |
13 | , unpadCryptoMsg | 15 | , unpadCryptoMsg |
14 | , decodeRawCryptoMsg | 16 | , decodeRawCryptoMsg |
15 | , createRequestPacket | ||
16 | , parseHandshakes | 17 | , parseHandshakes |
17 | , encodeHandshakes | 18 | , encodeHandshakes |
18 | , CryptoData(..) | 19 | , CryptoData(..) |
@@ -22,7 +23,6 @@ module Network.Tox.Crypto.Transport | |||
22 | , HandshakeData(..) | 23 | , HandshakeData(..) |
23 | , Handshake(..) | 24 | , Handshake(..) |
24 | , PeerInfo(..) | 25 | , PeerInfo(..) |
25 | , module Data.Tox.Message | ||
26 | , UserStatus(..) | 26 | , UserStatus(..) |
27 | , TypingStatus(..) | 27 | , TypingStatus(..) |
28 | , GroupChatId(..) | 28 | , GroupChatId(..) |
@@ -43,13 +43,9 @@ module Network.Tox.Crypto.Transport | |||
43 | , HasMessage(..) | 43 | , HasMessage(..) |
44 | , HasMessageType(..) | 44 | , HasMessageType(..) |
45 | -- lenses | 45 | -- lenses |
46 | , userStatus, nick, statusMessage, typingStatus, action, groupChatID | ||
47 | , groupNumber, groupNumberToJoin, peerNumber, messageNumber | 46 | , groupNumber, groupNumberToJoin, peerNumber, messageNumber |
48 | , messageName, messageData, name, title, message, messageType | 47 | , messageName, messageData, name, title, message, messageType |
49 | -- constructor | 48 | -- constructor |
50 | , msg | ||
51 | , leaveMsg | ||
52 | , peerQueryMsg | ||
53 | -- utils | 49 | -- utils |
54 | , sizedN | 50 | , sizedN |
55 | , sizedAtLeastN | 51 | , sizedAtLeastN |
@@ -57,19 +53,21 @@ module Network.Tox.Crypto.Transport | |||
57 | , fromEnum8 | 53 | , fromEnum8 |
58 | , fromEnum16 | 54 | , fromEnum16 |
59 | , toEnum8 | 55 | , toEnum8 |
60 | , msgSizeParam | ||
61 | , getCryptoMessage | 56 | , getCryptoMessage |
62 | , putCryptoMessage | 57 | , putCryptoMessage |
63 | , module Data.Tox.Message | ||
64 | ) where | 58 | ) where |
65 | 59 | ||
66 | import Crypto.Tox | 60 | import Crypto.Tox |
67 | import Data.Tox.Message | 61 | import Data.Tox.Msg |
68 | import Network.Tox.DHT.Transport (Cookie) | 62 | import Network.Tox.DHT.Transport (Cookie) |
69 | import Network.Tox.NodeId | 63 | import Network.Tox.NodeId |
64 | import DPut | ||
65 | import DebugTag | ||
66 | import Data.PacketBuffer as PB | ||
70 | 67 | ||
71 | import Network.Socket | 68 | import Network.Socket |
72 | import Data.ByteArray | 69 | import Data.ByteArray |
70 | import Data.Dependent.Sum | ||
73 | 71 | ||
74 | import Control.Monad | 72 | import Control.Monad |
75 | import Data.ByteString as B | 73 | import Data.ByteString as B |
@@ -84,14 +82,10 @@ import Data.Text as T | |||
84 | import Data.Text.Encoding as T | 82 | import Data.Text.Encoding as T |
85 | import Data.Serialize as S | 83 | import Data.Serialize as S |
86 | import Control.Arrow | 84 | import Control.Arrow |
87 | import DPut | 85 | import GHC.TypeNats |
88 | import DebugTag | ||
89 | import Data.PacketBuffer as PB | ||
90 | 86 | ||
91 | showCryptoMsg :: Word32 -> CryptoMessage -> [Char] | 87 | showCryptoMsg :: Word32 -> CryptoMessage -> [Char] |
92 | showCryptoMsg seqno (UpToN PacketRequest bytes) = "UpToN PacketRequest --> " | 88 | showCryptoMsg _ msg = show msg |
93 | ++ show (PB.decompressSequenceNumbers seqno $ B.unpack bytes) | ||
94 | showCryptoMsg _ msg = show msg | ||
95 | 89 | ||
96 | parseCrypto :: (ByteString, SockAddr) -> Either (CryptoPacket Encrypted, SockAddr) (ByteString, SockAddr) | 90 | parseCrypto :: (ByteString, SockAddr) -> Either (CryptoPacket Encrypted, SockAddr) (ByteString, SockAddr) |
97 | parseCrypto (bbs,saddr) = case B.uncons bbs of | 91 | parseCrypto (bbs,saddr) = case B.uncons bbs of |
@@ -110,6 +104,7 @@ parseHandshakes bs _ = Left $ "parseHandshakes_: | |||
110 | encodeHandshakes :: Handshake Encrypted -> SockAddr -> (ByteString, SockAddr) | 104 | encodeHandshakes :: Handshake Encrypted -> SockAddr -> (ByteString, SockAddr) |
111 | encodeHandshakes x saddr = (B.cons 0x1a (runPut $ put x),saddr) | 105 | encodeHandshakes x saddr = (B.cons 0x1a (runPut $ put x),saddr) |
112 | 106 | ||
107 | {- | ||
113 | createRequestPacket :: Word32 -> [Word32] -> CryptoMessage | 108 | createRequestPacket :: Word32 -> [Word32] -> CryptoMessage |
114 | createRequestPacket seqno xs = let r = UpToN PacketRequest (B.pack ns) | 109 | createRequestPacket seqno xs = let r = UpToN PacketRequest (B.pack ns) |
115 | in dtrace XNetCrypto ("createRequestPacket " ++ show seqno ++ " " ++ show xs ++ " -----> " ++ show r) r | 110 | in dtrace XNetCrypto ("createRequestPacket " ++ show seqno ++ " " ++ show xs ++ " -----> " ++ show r) r |
@@ -125,6 +120,7 @@ createRequestPacket seqno xs = let r = UpToN PacketRequest (B.pack ns) | |||
125 | in zeros ++ [m] | 120 | in zeros ++ [m] |
126 | ns :: [Word8] | 121 | ns :: [Word8] |
127 | ns = Prelude.map fromIntegral (reduceToSums ys >>= makeZeroes) | 122 | ns = Prelude.map fromIntegral (reduceToSums ys >>= makeZeroes) |
123 | -} | ||
128 | 124 | ||
129 | data Handshake (f :: * -> *) = Handshake | 125 | data Handshake (f :: * -> *) = Handshake |
130 | { -- The cookie is a cookie obtained by | 126 | { -- The cookie is a cookie obtained by |
@@ -247,25 +243,6 @@ instance Serialize CryptoData where | |||
247 | put seqno | 243 | put seqno |
248 | putCryptoMessage ack dta | 244 | putCryptoMessage ack dta |
249 | 245 | ||
250 | -- The 'UserStatus' equivalent in Presence is: | ||
251 | -- | ||
252 | -- data JabberShow = Offline | ||
253 | -- | ExtendedAway | ||
254 | -- | Away -- Tox equiv: Away (1) | ||
255 | -- | DoNotDisturb -- Tox equiv: Busy (2) | ||
256 | -- | Available -- Tox equiv: Online (0) | ||
257 | -- | Chatty | ||
258 | -- deriving (Show,Enum,Ord,Eq,Read) | ||
259 | -- | ||
260 | -- The Enum instance on 'UserStatus' is not arbitrary. It corresponds | ||
261 | -- to on-the-wire id numbers. | ||
262 | data UserStatus = Online | Away | Busy deriving (Show,Read,Eq,Ord,Enum) | ||
263 | instance Serialize UserStatus where | ||
264 | get = do | ||
265 | x <- get :: Get Word8 | ||
266 | return (toEnum8 x) | ||
267 | put x = put (fromEnum8 x) | ||
268 | |||
269 | data TypingStatus = NotTyping | Typing deriving (Show,Read,Eq,Ord,Enum) | 246 | data TypingStatus = NotTyping | Typing deriving (Show,Read,Eq,Ord,Enum) |
270 | instance Serialize TypingStatus where | 247 | instance Serialize TypingStatus where |
271 | get = do | 248 | get = do |
@@ -274,114 +251,41 @@ instance Serialize TypingStatus where | |||
274 | put x = put (fromEnum8 x :: Word8) | 251 | put x = put (fromEnum8 x :: Word8) |
275 | 252 | ||
276 | unpadCryptoMsg :: CryptoMessage -> CryptoMessage | 253 | unpadCryptoMsg :: CryptoMessage -> CryptoMessage |
277 | unpadCryptoMsg x@(TwoByte Padding (toEnum8 -> mid)) | 254 | unpadCryptoMsg msg@(Pkt Padding :=> Identity (Padded bs)) = |
278 | | msgSizeParam mid == Just (True,0) = OneByte mid | 255 | let unpadded = B.dropWhile (== msgbyte Padding) bs |
279 | unpadCryptoMsg x@(UpToN mid0 (B.dropWhile (==0) -> B.uncons -> Just (toEnum8 -> mid,bytes))) | 256 | in either (const msg) id $ runGet (getCryptoMessage 0) unpadded |
280 | | mid0 == Padding | 257 | unpadCryptoMsg msg = msg |
281 | = case msgSizeParam mid of | ||
282 | Just (True,0) -> OneByte mid | ||
283 | Just (True,1) -> TwoByte mid (B.head bytes) | ||
284 | _ -> UpToN mid bytes | ||
285 | unpadCryptoMsg x = x | ||
286 | 258 | ||
287 | decodeRawCryptoMsg :: CryptoData -> CryptoMessage | 259 | decodeRawCryptoMsg :: CryptoData -> CryptoMessage |
288 | decodeRawCryptoMsg (CryptoData ack seqno cm) = | 260 | decodeRawCryptoMsg (CryptoData ack seqno cm) = unpadCryptoMsg cm |
289 | let cm' = unpadCryptoMsg cm | ||
290 | in case msgID cm' of | ||
291 | PacketRequest -> RequestResend PacketRequest $ decompressSequenceNumbers ack $ msgByteList cm' | ||
292 | _ -> cm' | ||
293 | |||
294 | data CryptoMessage | ||
295 | = OneByte { msgID :: MessageID } | ||
296 | | TwoByte { msgID :: MessageID, msgByte :: Word8 } | ||
297 | | UpToN { msgID :: MessageID, msgBytes :: ByteString } -- length < N | ||
298 | -- | TODO: The msgID field is redundant in this case and can be removed | ||
299 | -- after all uses are audited. | ||
300 | | RequestResend { msgID :: MessageID, requested :: [Word32] } | ||
301 | deriving (Eq,Show) | ||
302 | |||
303 | msgByteList :: CryptoMessage -> [Word8] | ||
304 | msgByteList (UpToN _ bs) = B.unpack bs | ||
305 | msgByteList (TwoByte _ b) = [b] | ||
306 | msgByteList (OneByte _) = [] | ||
307 | 261 | ||
308 | instance Sized CryptoMessage where | 262 | instance Sized CryptoMessage where |
309 | size = VarSize $ \case | 263 | size = VarSize $ \case |
310 | OneByte {} -> 1 | 264 | Pkt t :=> Identity x -> case sizeFor t of |
311 | TwoByte {} -> 2 | 265 | ConstSize sz -> 1 + sz |
312 | UpToN { msgBytes = bs } -> 1 + B.length bs | 266 | VarSize f -> 1 + f x |
313 | RequestResend { requested = ws } -> 1 + Prelude.length ws | 267 | |
268 | sizeFor :: Sized x => p x -> Size x | ||
269 | sizeFor _ = size | ||
270 | |||
314 | 271 | ||
315 | getCryptoMessage :: Word32 -> Get CryptoMessage | 272 | getCryptoMessage :: Word32 -> Get CryptoMessage |
316 | getCryptoMessage seqno = do | 273 | getCryptoMessage seqno = do |
317 | i <- get :: Get MessageID | 274 | t <- getWord8 |
318 | n <- remaining | 275 | case msgTag t of |
319 | pkt <- case msgSizeParam i of | 276 | Just (M msg) -> do x <- getPacket seqno |
320 | Just (True,0) -> return $ OneByte i | 277 | return $ Pkt msg ==> x |
321 | Just (True,1) -> TwoByte i <$> get | 278 | Nothing -> return $ Pkt Padding ==> Padded mempty |
322 | _ -> UpToN i <$> getByteString n | ||
323 | return $ if msgID pkt == PacketRequest | ||
324 | then RequestResend PacketRequest $ decompressSequenceNumbers seqno $ msgByteList pkt | ||
325 | else pkt | ||
326 | 279 | ||
327 | putCryptoMessage :: Word32 -> CryptoMessage -> Put | 280 | putCryptoMessage :: Word32 -> CryptoMessage -> Put |
328 | putCryptoMessage seqno (OneByte i) = putWord8 (fromIntegral . fromEnum $ i) | 281 | putCryptoMessage seqno (Pkt t :=> Identity x) = do |
329 | putCryptoMessage seqno (TwoByte i b) = do putWord8 (fromIntegral . fromEnum $ i) | 282 | putWord8 (msgbyte t) |
330 | putWord8 b | 283 | putPacket seqno x |
331 | putCryptoMessage seqno (UpToN i x) = do putWord8 (fromIntegral . fromEnum $ i) | 284 | |
332 | putByteString x | 285 | |
333 | putCryptoMessage seqno (RequestResend _ ws) = do | ||
334 | putWord8 (fromIntegral . fromEnum $ PacketRequest) | ||
335 | mapM_ putWord8 $ compressSequenceNumbers seqno ws | ||
336 | |||
337 | instance Serialize MessageID where | ||
338 | get = toEnum . fromIntegral <$> getWord8 | ||
339 | put x = putWord8 (fromIntegral . fromEnum $ x) | ||
340 | |||
341 | erCompat :: String -> a | 286 | erCompat :: String -> a |
342 | erCompat lens = error $ "Use of '" ++ lens ++ "' lens on incompatible CryptoMessage type" | 287 | erCompat lens = error $ "Use of '" ++ lens ++ "' lens on incompatible CryptoMessage type" |
343 | 288 | ||
344 | typingStatus :: Functor f => (UserStatus -> f UserStatus)-> (CryptoMessage -> f CryptoMessage) | ||
345 | typingStatus = lens getter setter | ||
346 | where | ||
347 | getter :: CryptoMessage -> UserStatus | ||
348 | getter (TwoByte TYPING status) = toEnum $ fromIntegral status | ||
349 | getter _ = erCompat "typingStatus" | ||
350 | setter :: CryptoMessage -> UserStatus -> CryptoMessage | ||
351 | setter (TwoByte TYPING _) status = TwoByte TYPING (fromIntegral . fromEnum $ status) | ||
352 | setter _ _ = erCompat "typingStatus" | ||
353 | |||
354 | userStatus :: Functor f => (UserStatus -> f UserStatus)-> (CryptoMessage -> f CryptoMessage) | ||
355 | userStatus = lens getter setter | ||
356 | where | ||
357 | getter (TwoByte USERSTATUS status) = toEnum $ fromIntegral status | ||
358 | getter _ = erCompat "userStatus" | ||
359 | setter (TwoByte USERSTATUS _) status = TwoByte USERSTATUS (fromIntegral . fromEnum $ status) | ||
360 | setter _ _ = erCompat "userStatus" | ||
361 | |||
362 | nick :: Functor f => (Text -> f Text)-> (CryptoMessage -> f CryptoMessage) | ||
363 | nick = lens getter setter | ||
364 | where | ||
365 | getter (UpToN NICKNAME bstr) = T.decodeUtf8 bstr | ||
366 | getter _ = erCompat "nick" | ||
367 | setter (UpToN NICKNAME _) nick = UpToN NICKNAME (T.encodeUtf8 $ nick) | ||
368 | setter _ _ = erCompat "nick" | ||
369 | |||
370 | statusMessage :: Functor f => (String -> f String)-> (CryptoMessage -> f CryptoMessage) | ||
371 | statusMessage = lens getter setter | ||
372 | where | ||
373 | getter (UpToN STATUSMESSAGE bstr) = T.unpack $ T.decodeUtf8 bstr | ||
374 | getter _ = erCompat "statusMessage" | ||
375 | setter (UpToN STATUSMESSAGE _) nick = UpToN STATUSMESSAGE (T.encodeUtf8 . T.pack $ nick) | ||
376 | setter _ _ = erCompat "statusMessage" | ||
377 | |||
378 | action :: Functor f => (String -> f String)-> (CryptoMessage -> f CryptoMessage) | ||
379 | action = lens getter setter | ||
380 | where | ||
381 | getter (UpToN ACTION bstr) = T.unpack $ T.decodeUtf8 bstr | ||
382 | getter _ = erCompat "action" | ||
383 | setter (UpToN ACTION _) action = UpToN ACTION (T.encodeUtf8 . T.pack $ action) | ||
384 | setter _ _ = erCompat "action" | ||
385 | 289 | ||
386 | newtype GroupChatId = GrpId ByteString -- 33 bytes | 290 | newtype GroupChatId = GrpId ByteString -- 33 bytes |
387 | deriving (Show,Eq) | 291 | deriving (Show,Eq) |
@@ -398,9 +302,10 @@ sizedAtLeastN :: Int -> ByteString -> ByteString | |||
398 | sizedAtLeastN n bs = if B.length bs < n then B.append bs (B.replicate (n - B.length bs) 0) | 302 | sizedAtLeastN n bs = if B.length bs < n then B.append bs (B.replicate (n - B.length bs) 0) |
399 | else bs | 303 | else bs |
400 | 304 | ||
305 | {- | ||
401 | instance HasGroupChatID CryptoMessage where | 306 | instance HasGroupChatID CryptoMessage where |
402 | -- Get | 307 | -- Get |
403 | getGroupChatID (UpToN INVITE_GROUPCHAT payload) | 308 | getGroupChatID (Pkt INVITE_CONFERENCE :=> Identity payload) |
404 | = let (xs,ys) = B.splitAt 1 payload' | 309 | = let (xs,ys) = B.splitAt 1 payload' |
405 | payload' = sizedN 38 payload | 310 | payload' = sizedN 38 payload |
406 | in case B.unpack xs of | 311 | in case B.unpack xs of |
@@ -408,11 +313,11 @@ instance HasGroupChatID CryptoMessage where | |||
408 | [isResponse] | 1 <- isResponse -> GrpId (B.take 33 $ B.drop 4 ys) -- skip two group numbers | 313 | [isResponse] | 1 <- isResponse -> GrpId (B.take 33 $ B.drop 4 ys) -- skip two group numbers |
409 | _ -> GrpId "" -- error "Unexpected value in INVITE_GROUPCHAT message" | 314 | _ -> GrpId "" -- error "Unexpected value in INVITE_GROUPCHAT message" |
410 | 315 | ||
411 | getGroupChatID (UpToN ONLINE_PACKET payload) = GrpId (B.take 33 $ B.drop 2 (sizedN 35 payload)) | 316 | getGroupChatID (Pkt ONLINE_PACKET :=> Identity payload) = GrpId (B.take 33 $ B.drop 2 (sizedN 35 payload)) |
412 | getGroupChatID _ = error "getGroupChatID on non-groupchat message." | 317 | getGroupChatID _ = error "getGroupChatID on non-groupchat message." |
413 | 318 | ||
414 | -- Set | 319 | -- Set |
415 | setGroupChatID msg@(UpToN INVITE_GROUPCHAT payload) (GrpId newid) | 320 | setGroupChatID msg@(Pkt INVITE_CONFERENCE :=> Identity payload) (GrpId newid) |
416 | = let (xs,ys) = B.splitAt 1 payload' | 321 | = let (xs,ys) = B.splitAt 1 payload' |
417 | payload' = sizedN 38 payload | 322 | payload' = sizedN 38 payload |
418 | in case B.unpack xs of | 323 | in case B.unpack xs of |
@@ -420,8 +325,9 @@ instance HasGroupChatID CryptoMessage where | |||
420 | [isResponse] | 1 <- isResponse -> UpToN INVITE_GROUPCHAT (B.concat [xs, (B.take 4 ys), sizedN 33 newid]) -- keep two group numbers | 325 | [isResponse] | 1 <- isResponse -> UpToN INVITE_GROUPCHAT (B.concat [xs, (B.take 4 ys), sizedN 33 newid]) -- keep two group numbers |
421 | _ -> msg -- unexpected condition, leave unchanged | 326 | _ -> msg -- unexpected condition, leave unchanged |
422 | 327 | ||
423 | setGroupChatID (UpToN ONLINE_PACKET payload) (GrpId newid) = UpToN ONLINE_PACKET (B.concat [B.take 2 payload, sizedN 33 newid]) | 328 | setGroupChatID (Pkt ONLINE_PACKET :=> Identity payload) (GrpId newid) = Pkt ONLINE_PACKET ==> (B.concat [B.take 2 payload, sizedN 33 newid]) |
424 | setGroupChatID _ _= error "setGroupChatID on non-groupchat message." | 329 | setGroupChatID _ _= error "setGroupChatID on non-groupchat message." |
330 | -} | ||
425 | 331 | ||
426 | groupChatID :: (Functor f, HasGroupChatID x) => (GroupChatId -> f GroupChatId) -> (x -> f x) | 332 | groupChatID :: (Functor f, HasGroupChatID x) => (GroupChatId -> f GroupChatId) -> (x -> f x) |
427 | groupChatID = lens getGroupChatID setGroupChatID | 333 | groupChatID = lens getGroupChatID setGroupChatID |
@@ -434,8 +340,9 @@ class HasGroupNumber x where | |||
434 | getGroupNumber :: x -> GroupNumber | 340 | getGroupNumber :: x -> GroupNumber |
435 | setGroupNumber :: x -> GroupNumber -> x | 341 | setGroupNumber :: x -> GroupNumber -> x |
436 | 342 | ||
343 | {- | ||
437 | instance HasGroupNumber CryptoMessage where | 344 | instance HasGroupNumber CryptoMessage where |
438 | getGroupNumber (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (isResp,xs))) -- note isResp should be 0 or 1 | 345 | getGroupNumber (Pkt INVITE_CONFERENCE :=> Identity (sizedN 39 -> B.uncons -> Just (isResp,xs))) -- note isResp should be 0 or 1 |
439 | = let twobytes = B.take 2 xs | 346 | = let twobytes = B.take 2 xs |
440 | Right n = S.decode twobytes | 347 | Right n = S.decode twobytes |
441 | in n | 348 | in n |
@@ -452,6 +359,7 @@ instance HasGroupNumber CryptoMessage where | |||
452 | | x >= 0x61 && x <= 0x63 = UpToN xE (B.append (S.encode groupnum) xs) | 359 | | x >= 0x61 && x <= 0x63 = UpToN xE (B.append (S.encode groupnum) xs) |
453 | | x == 0xC7 = UpToN xE (B.append (S.encode groupnum) xs) | 360 | | x == 0xC7 = UpToN xE (B.append (S.encode groupnum) xs) |
454 | setGroupNumber _ _ = error "setGroupNumber on CryptoMessage without group number field." | 361 | setGroupNumber _ _ = error "setGroupNumber on CryptoMessage without group number field." |
362 | -} | ||
455 | 363 | ||
456 | groupNumber :: (Functor f, HasGroupNumber x) => (Word16 -> f Word16) -> (x -> f x) | 364 | groupNumber :: (Functor f, HasGroupNumber x) => (Word16 -> f Word16) -> (x -> f x) |
457 | groupNumber = lens getGroupNumber setGroupNumber | 365 | groupNumber = lens getGroupNumber setGroupNumber |
@@ -460,6 +368,7 @@ class HasGroupNumberToJoin x where | |||
460 | getGroupNumberToJoin :: x -> GroupNumber | 368 | getGroupNumberToJoin :: x -> GroupNumber |
461 | setGroupNumberToJoin :: x -> GroupNumber -> x | 369 | setGroupNumberToJoin :: x -> GroupNumber -> x |
462 | 370 | ||
371 | {- | ||
463 | instance HasGroupNumberToJoin CryptoMessage where | 372 | instance HasGroupNumberToJoin CryptoMessage where |
464 | getGroupNumberToJoin (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (1,xs))) -- only response has to-join | 373 | getGroupNumberToJoin (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (1,xs))) -- only response has to-join |
465 | = let twobytes = B.take 2 (B.drop 2 xs) -- skip group number (local) | 374 | = let twobytes = B.take 2 (B.drop 2 xs) -- skip group number (local) |
@@ -472,6 +381,7 @@ instance HasGroupNumberToJoin CryptoMessage where | |||
472 | twoBytes' = S.encode groupnum | 381 | twoBytes' = S.encode groupnum |
473 | in UpToN INVITE_GROUPCHAT (B.cons 1 (B.concat [a,twoBytes',c])) | 382 | in UpToN INVITE_GROUPCHAT (B.cons 1 (B.concat [a,twoBytes',c])) |
474 | setGroupNumberToJoin _ _ = error "setGroupNumberToJoin on CryptoMessage without group number (to join) field." | 383 | setGroupNumberToJoin _ _ = error "setGroupNumberToJoin on CryptoMessage without group number (to join) field." |
384 | -} | ||
475 | 385 | ||
476 | groupNumberToJoin :: (Functor f, HasGroupNumberToJoin x) => (GroupNumber -> f GroupNumber) -> (x -> f x) | 386 | groupNumberToJoin :: (Functor f, HasGroupNumberToJoin x) => (GroupNumber -> f GroupNumber) -> (x -> f x) |
477 | groupNumberToJoin = lens getGroupNumberToJoin setGroupNumberToJoin | 387 | groupNumberToJoin = lens getGroupNumberToJoin setGroupNumberToJoin |
@@ -480,6 +390,7 @@ class HasPeerNumber x where | |||
480 | getPeerNumber :: x -> PeerNumber | 390 | getPeerNumber :: x -> PeerNumber |
481 | setPeerNumber :: x -> PeerNumber -> x | 391 | setPeerNumber :: x -> PeerNumber -> x |
482 | 392 | ||
393 | {- | ||
483 | instance HasPeerNumber CryptoMessage where | 394 | instance HasPeerNumber CryptoMessage where |
484 | getPeerNumber (UpToN (fromEnum -> 0x63) (sizedN 4 -> B.splitAt 2 -> (grpnum,twobytes))) | 395 | getPeerNumber (UpToN (fromEnum -> 0x63) (sizedN 4 -> B.splitAt 2 -> (grpnum,twobytes))) |
485 | = let Right n = S.decode twobytes in n | 396 | = let Right n = S.decode twobytes in n |
@@ -492,6 +403,7 @@ instance HasPeerNumber CryptoMessage where | |||
492 | setPeerNumber (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 4 -> B.splitAt 2 -> (gnum,xs))) peernum | 403 | setPeerNumber (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 4 -> B.splitAt 2 -> (gnum,xs))) peernum |
493 | = UpToN xE (B.concat [gnum,S.encode peernum, B.drop 2 xs]) | 404 | = UpToN xE (B.concat [gnum,S.encode peernum, B.drop 2 xs]) |
494 | setPeerNumber _ _ = error "setPeerNumber on CryptoMessage without peer number field." | 405 | setPeerNumber _ _ = error "setPeerNumber on CryptoMessage without peer number field." |
406 | -} | ||
495 | 407 | ||
496 | peerNumber :: (Functor f, HasPeerNumber x) => (Word16 -> f Word16) -> (x -> f x) | 408 | peerNumber :: (Functor f, HasPeerNumber x) => (Word16 -> f Word16) -> (x -> f x) |
497 | peerNumber = lens getPeerNumber setPeerNumber | 409 | peerNumber = lens getPeerNumber setPeerNumber |
@@ -500,6 +412,7 @@ class HasMessageNumber x where | |||
500 | getMessageNumber :: x -> MessageNumber | 412 | getMessageNumber :: x -> MessageNumber |
501 | setMessageNumber :: x -> MessageNumber -> x | 413 | setMessageNumber :: x -> MessageNumber -> x |
502 | 414 | ||
415 | {- | ||
503 | instance HasMessageNumber CryptoMessage where | 416 | instance HasMessageNumber CryptoMessage where |
504 | getMessageNumber (UpToN (fromEnum -> 0x63) (sizedN 8 -> B.splitAt 4 -> (_,fourbytes))) | 417 | getMessageNumber (UpToN (fromEnum -> 0x63) (sizedN 8 -> B.splitAt 4 -> (_,fourbytes))) |
505 | = let Right n = S.decode fourbytes in n | 418 | = let Right n = S.decode fourbytes in n |
@@ -512,6 +425,7 @@ instance HasMessageNumber CryptoMessage where | |||
512 | setMessageNumber (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 8 -> B.splitAt 4 -> (bs,xs))) messagenum | 425 | setMessageNumber (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 8 -> B.splitAt 4 -> (bs,xs))) messagenum |
513 | = UpToN xE (B.concat [bs,S.encode messagenum, B.drop 4 xs]) | 426 | = UpToN xE (B.concat [bs,S.encode messagenum, B.drop 4 xs]) |
514 | setMessageNumber _ _ = error "setMessageNumber on CryptoMessage without message number field." | 427 | setMessageNumber _ _ = error "setMessageNumber on CryptoMessage without message number field." |
428 | -} | ||
515 | 429 | ||
516 | messageNumber :: (Functor f, HasMessageNumber x) => (Word32 -> f Word32) -> (x -> f x) | 430 | messageNumber :: (Functor f, HasMessageNumber x) => (Word32 -> f Word32) -> (x -> f x) |
517 | messageNumber = lens getMessageNumber setMessageNumber | 431 | messageNumber = lens getMessageNumber setMessageNumber |
@@ -521,6 +435,7 @@ class HasMessageName x where | |||
521 | getMessageName :: x -> MessageName | 435 | getMessageName :: x -> MessageName |
522 | setMessageName :: x -> MessageName -> x | 436 | setMessageName :: x -> MessageName -> x |
523 | 437 | ||
438 | {- | ||
524 | instance HasMessageName CryptoMessage where | 439 | instance HasMessageName CryptoMessage where |
525 | getMessageName (UpToN (fromEnum -> 0x63) (sizedN 9 -> B.splitAt 8 -> (_,onebyte))) | 440 | getMessageName (UpToN (fromEnum -> 0x63) (sizedN 9 -> B.splitAt 8 -> (_,onebyte))) |
526 | = let [n] = B.unpack onebyte | 441 | = let [n] = B.unpack onebyte |
@@ -535,6 +450,7 @@ instance HasMessageName CryptoMessage where | |||
535 | setMessageName (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,xs))) messagename | 450 | setMessageName (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,xs))) messagename |
536 | = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum messagename) (B.drop 1 xs)]) | 451 | = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum messagename) (B.drop 1 xs)]) |
537 | setMessageName _ _ = error "setMessageName on CryptoMessage without message name field." | 452 | setMessageName _ _ = error "setMessageName on CryptoMessage without message name field." |
453 | -} | ||
538 | 454 | ||
539 | messageName :: (Functor f, HasMessageName x) => (MessageName -> f MessageName) -> (x -> f x) | 455 | messageName :: (Functor f, HasMessageName x) => (MessageName -> f MessageName) -> (x -> f x) |
540 | messageName = lens getMessageName setMessageName | 456 | messageName = lens getMessageName setMessageName |
@@ -542,7 +458,7 @@ messageName = lens getMessageName setMessageName | |||
542 | data KnownLossyness = KnownLossy | KnownLossless | 458 | data KnownLossyness = KnownLossy | KnownLossless |
543 | deriving (Eq,Ord,Show,Enum) | 459 | deriving (Eq,Ord,Show,Enum) |
544 | 460 | ||
545 | data MessageType = Msg MessageID | 461 | data MessageType = Msg Word8 |
546 | | GrpMsg KnownLossyness MessageName | 462 | | GrpMsg KnownLossyness MessageName |
547 | deriving (Eq,Show) | 463 | deriving (Eq,Show) |
548 | 464 | ||
@@ -555,11 +471,6 @@ class AsWord64 a where | |||
555 | fromWord64 :: Word64 -> a | 471 | fromWord64 :: Word64 -> a |
556 | 472 | ||
557 | 473 | ||
558 | toEnum8 :: (Enum a, Integral word8) => word8 -> a | ||
559 | toEnum8 = toEnum . fromIntegral | ||
560 | fromEnum8 :: Enum a => a -> Word8 | ||
561 | fromEnum8 = fromIntegral . fromEnum | ||
562 | |||
563 | fromEnum16 :: Enum a => a -> Word16 | 474 | fromEnum16 :: Enum a => a -> Word16 |
564 | fromEnum16 = fromIntegral . fromEnum | 475 | fromEnum16 = fromIntegral . fromEnum |
565 | 476 | ||
@@ -599,6 +510,7 @@ class HasMessageType x where | |||
599 | getMessageType :: x -> MessageType | 510 | getMessageType :: x -> MessageType |
600 | setMessageType :: x -> MessageType -> x | 511 | setMessageType :: x -> MessageType -> x |
601 | 512 | ||
513 | {- | ||
602 | instance HasMessageType CryptoMessage where | 514 | instance HasMessageType CryptoMessage where |
603 | getMessageType (OneByte mid) = Msg mid | 515 | getMessageType (OneByte mid) = Msg mid |
604 | getMessageType (TwoByte mid _) = Msg mid | 516 | getMessageType (TwoByte mid _) = Msg mid |
@@ -619,10 +531,13 @@ instance HasMessageType CryptoMessage where | |||
619 | setMessageType (OneByte mid0) (Msg mid) = UpToN mid B.empty | 531 | setMessageType (OneByte mid0) (Msg mid) = UpToN mid B.empty |
620 | setMessageType (TwoByte mid0 x) (Msg mid) = UpToN mid (B.singleton x) | 532 | setMessageType (TwoByte mid0 x) (Msg mid) = UpToN mid (B.singleton x) |
621 | setMessageType (UpToN mid0 x) (Msg mid) = UpToN mid x | 533 | setMessageType (UpToN mid0 x) (Msg mid) = UpToN mid x |
534 | -} | ||
622 | 535 | ||
536 | {- | ||
623 | instance HasMessageType CryptoData where | 537 | instance HasMessageType CryptoData where |
624 | getMessageType (CryptoData { bufferData }) = getMessageType bufferData | 538 | getMessageType (CryptoData { bufferData }) = getMessageType bufferData |
625 | setMessageType cd@(CryptoData { bufferData=bd }) typ = cd { bufferData=setMessageType bd typ } | 539 | setMessageType cd@(CryptoData { bufferData=bd }) typ = cd { bufferData=setMessageType bd typ } |
540 | -} | ||
626 | 541 | ||
627 | -- | This lens should always succeed on CryptoMessage | 542 | -- | This lens should always succeed on CryptoMessage |
628 | messageType :: (Functor f, HasMessageType x) => (MessageType -> f MessageType) -> (x -> f x) | 543 | messageType :: (Functor f, HasMessageType x) => (MessageType -> f MessageType) -> (x -> f x) |
@@ -634,6 +549,7 @@ class HasMessageData x where | |||
634 | getMessageData :: x -> MessageData | 549 | getMessageData :: x -> MessageData |
635 | setMessageData :: x -> MessageData -> x | 550 | setMessageData :: x -> MessageData -> x |
636 | 551 | ||
552 | {- | ||
637 | instance HasMessageData CryptoMessage where | 553 | instance HasMessageData CryptoMessage where |
638 | getMessageData (UpToN (fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 9 -> (_,mdata))) = mdata | 554 | getMessageData (UpToN (fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 9 -> (_,mdata))) = mdata |
639 | getMessageData (UpToN (fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 9 -> (_,mdata))) = mdata | 555 | getMessageData (UpToN (fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 9 -> (_,mdata))) = mdata |
@@ -649,6 +565,7 @@ instance HasMessageData CryptoMessage where | |||
649 | setMessageData (UpToN xE@(fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 3 -> (bs,xs))) peerinfosOrTitle -- peer/title response packets | 565 | setMessageData (UpToN xE@(fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 3 -> (bs,xs))) peerinfosOrTitle -- peer/title response packets |
650 | = UpToN xE (B.concat [bs,peerinfosOrTitle]) | 566 | = UpToN xE (B.concat [bs,peerinfosOrTitle]) |
651 | setMessageData _ _ = error "setMessageData on CryptoMessage without message data field." | 567 | setMessageData _ _ = error "setMessageData on CryptoMessage without message data field." |
568 | -} | ||
652 | 569 | ||
653 | messageData :: (Functor f, HasMessageData x) => (MessageData -> f MessageData) -> (x -> f x) | 570 | messageData :: (Functor f, HasMessageData x) => (MessageData -> f MessageData) -> (x -> f x) |
654 | messageData = lens getMessageData setMessageData | 571 | messageData = lens getMessageData setMessageData |
@@ -657,6 +574,7 @@ class HasTitle x where | |||
657 | getTitle :: x -> Text | 574 | getTitle :: x -> Text |
658 | setTitle :: x -> Text -> x | 575 | setTitle :: x -> Text -> x |
659 | 576 | ||
577 | {- | ||
660 | instance HasTitle CryptoMessage where | 578 | instance HasTitle CryptoMessage where |
661 | getTitle (UpToN xE bs) | 579 | getTitle (UpToN xE bs) |
662 | | DIRECT_GROUPCHAT {-0x62-} <- xE, | 580 | | DIRECT_GROUPCHAT {-0x62-} <- xE, |
@@ -677,6 +595,7 @@ instance HasTitle CryptoMessage where | |||
677 | nm = fromIntegral $ fromEnum GroupchatTitleChange | 595 | nm = fromIntegral $ fromEnum GroupchatTitleChange |
678 | in UpToN xE (pre <> B.cons nm (encodeUtf8 msgdta)) | 596 | in UpToN xE (pre <> B.cons nm (encodeUtf8 msgdta)) |
679 | setTitle _ _ = error "setTitle on CryptoMessage without title field." | 597 | setTitle _ _ = error "setTitle on CryptoMessage without title field." |
598 | -} | ||
680 | 599 | ||
681 | title :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x) | 600 | title :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x) |
682 | title = lens getTitle setTitle | 601 | title = lens getTitle setTitle |
@@ -690,6 +609,7 @@ splitByteAt n bs = (fixed,w8,bs') | |||
690 | where | 609 | where |
691 | (fixed,B.uncons -> Just (w8,bs')) = B.splitAt n $ sizedAtLeastN (n+1) bs | 610 | (fixed,B.uncons -> Just (w8,bs')) = B.splitAt n $ sizedAtLeastN (n+1) bs |
692 | 611 | ||
612 | {- | ||
693 | instance HasMessage CryptoMessage where | 613 | instance HasMessage CryptoMessage where |
694 | getMessage (UpToN xE bs) | 614 | getMessage (UpToN xE bs) |
695 | | MESSAGE <- xE = T.decodeUtf8 bs | 615 | | MESSAGE <- xE = T.decodeUtf8 bs |
@@ -705,7 +625,7 @@ instance HasMessage CryptoMessage where | |||
705 | prefix x = pre8 <> B.cons nm x | 625 | prefix x = pre8 <> B.cons nm x |
706 | in UpToN xE $ prefix $ T.encodeUtf8 message | 626 | in UpToN xE $ prefix $ T.encodeUtf8 message |
707 | setMessage _ _ = error "setMessage on CryptoMessage without message field." | 627 | setMessage _ _ = error "setMessage on CryptoMessage without message field." |
708 | 628 | -} | |
709 | 629 | ||
710 | message :: (Functor f, HasMessage x) => (Text -> f Text) -> (x -> f x) | 630 | message :: (Functor f, HasMessage x) => (Text -> f Text) -> (x -> f x) |
711 | message = lens getMessage setMessage | 631 | message = lens getMessage setMessage |
@@ -715,6 +635,7 @@ class HasName x where | |||
715 | setName :: x -> Text -> x | 635 | setName :: x -> Text -> x |
716 | 636 | ||
717 | 637 | ||
638 | {- | ||
718 | instance HasName CryptoMessage where | 639 | instance HasName CryptoMessage where |
719 | -- Only MESSAGE_GROUPCHAT:NameChange has Name field | 640 | -- Only MESSAGE_GROUPCHAT:NameChange has Name field |
720 | getName (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (_,B.uncons -> Just (toEnum . fromIntegral -> NameChange,mdata)))) | isIndirectGrpChat xE = decodeUtf8 mdata | 641 | getName (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (_,B.uncons -> Just (toEnum . fromIntegral -> NameChange,mdata)))) | isIndirectGrpChat xE = decodeUtf8 mdata |
@@ -724,6 +645,7 @@ instance HasName CryptoMessage where | |||
724 | setName (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (bs,B.uncons -> Just (_,xs)))) name | 645 | setName (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (bs,B.uncons -> Just (_,xs)))) name |
725 | | isIndirectGrpChat xE = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum NameChange) (encodeUtf8 name)]) | 646 | | isIndirectGrpChat xE = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum NameChange) (encodeUtf8 name)]) |
726 | setName _ _ = error "setName on CryptoMessage without name field." | 647 | setName _ _ = error "setName on CryptoMessage without name field." |
648 | -} | ||
727 | 649 | ||
728 | name :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x) | 650 | name :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x) |
729 | name = lens getTitle setTitle | 651 | name = lens getTitle setTitle |
@@ -760,6 +682,7 @@ instance Serialize PeerInfo where | |||
760 | putByteString $ B.take (fromIntegral sz) bs | 682 | putByteString $ B.take (fromIntegral sz) bs |
761 | 683 | ||
762 | 684 | ||
685 | {- | ||
763 | -- | | 686 | -- | |
764 | -- default constructor, handy for formations such as: | 687 | -- default constructor, handy for formations such as: |
765 | -- | 688 | -- |
@@ -770,12 +693,15 @@ msg mid | Just (True,0) <- msgSizeParam mid = OneByte mid | |||
770 | | Just (True,1) <- msgSizeParam mid = TwoByte mid 0 | 693 | | Just (True,1) <- msgSizeParam mid = TwoByte mid 0 |
771 | | Just (False,_) <- msgSizeParam mid = UpToN mid B.empty | 694 | | Just (False,_) <- msgSizeParam mid = UpToN mid B.empty |
772 | | otherwise = UpToN mid B.empty | 695 | | otherwise = UpToN mid B.empty |
696 | -} | ||
773 | 697 | ||
698 | {- | ||
774 | leaveMsg, peerQueryMsg :: Serialize a => a -> CryptoMessage | 699 | leaveMsg, peerQueryMsg :: Serialize a => a -> CryptoMessage |
775 | leaveMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x01) | 700 | leaveMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x01) |
776 | peerQueryMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x08) | 701 | peerQueryMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x08) |
702 | -} | ||
777 | 703 | ||
778 | 704 | {- | |
779 | -- | Returns if the given message is of fixed(OneByte/TwoByte) size, as well as | 705 | -- | Returns if the given message is of fixed(OneByte/TwoByte) size, as well as |
780 | -- the maximum allowed size for the message Payload (message minus id) | 706 | -- the maximum allowed size for the message Payload (message minus id) |
781 | -- Or Nothing if unknown/unimplemented. | 707 | -- Or Nothing if unknown/unimplemented. |
@@ -797,19 +723,20 @@ msgSizeParam DIRECT_GROUPCHAT {-0x62-} = Nothing -- 1+2+1 thus Just (True,3) le | |||
797 | msgSizeParam MESSAGE_GROUPCHAT {-0x63-} = Nothing -- variable | 723 | msgSizeParam MESSAGE_GROUPCHAT {-0x63-} = Nothing -- variable |
798 | msgSizeParam LOSSY_GROUPCHAT {-0xC7-} = Nothing -- variable | 724 | msgSizeParam LOSSY_GROUPCHAT {-0xC7-} = Nothing -- variable |
799 | msgSizeParam _ = Nothing | 725 | msgSizeParam _ = Nothing |
726 | -} | ||
800 | 727 | ||
801 | isIndirectGrpChat :: MessageID -> Bool | 728 | isIndirectGrpChat :: Msg n t -> Bool |
802 | isIndirectGrpChat MESSAGE_GROUPCHAT = True | 729 | isIndirectGrpChat MESSAGE_CONFERENCE = True |
803 | isIndirectGrpChat LOSSY_GROUPCHAT = True | 730 | isIndirectGrpChat LOSSY_CONFERENCE = True |
804 | isIndirectGrpChat _ = False | 731 | isIndirectGrpChat _ = False |
805 | 732 | ||
806 | isKillPacket :: MessageType -> Bool | 733 | isKillPacket :: SomeMsg -> Bool |
807 | isKillPacket (Msg KillPacket) = True | 734 | isKillPacket (M KillPacket) = True |
808 | isKillPacket _ = False | 735 | isKillPacket _ = False |
809 | 736 | ||
810 | isOFFLINE :: MessageType -> Bool | 737 | isOFFLINE :: SomeMsg -> Bool |
811 | isOFFLINE (Msg OFFLINE) = True | 738 | isOFFLINE (M OFFLINE) = True |
812 | isOFFLINE _ = False | 739 | isOFFLINE _ = False |
813 | 740 | ||
814 | 741 | ||
815 | data MessageName = Ping -- 0x00 | 742 | data MessageName = Ping -- 0x00 |