summaryrefslogtreecommitdiff
path: root/src/Network/Tox/Crypto
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/Tox/Crypto')
-rw-r--r--src/Network/Tox/Crypto/Transport.hs231
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
66import Crypto.Tox 60import Crypto.Tox
67import Data.Tox.Message 61import Data.Tox.Msg
68import Network.Tox.DHT.Transport (Cookie) 62import Network.Tox.DHT.Transport (Cookie)
69import Network.Tox.NodeId 63import Network.Tox.NodeId
64import DPut
65import DebugTag
66import Data.PacketBuffer as PB
70 67
71import Network.Socket 68import Network.Socket
72import Data.ByteArray 69import Data.ByteArray
70import Data.Dependent.Sum
73 71
74import Control.Monad 72import Control.Monad
75import Data.ByteString as B 73import Data.ByteString as B
@@ -84,14 +82,10 @@ import Data.Text as T
84import Data.Text.Encoding as T 82import Data.Text.Encoding as T
85import Data.Serialize as S 83import Data.Serialize as S
86import Control.Arrow 84import Control.Arrow
87import DPut 85import GHC.TypeNats
88import DebugTag
89import Data.PacketBuffer as PB
90 86
91showCryptoMsg :: Word32 -> CryptoMessage -> [Char] 87showCryptoMsg :: Word32 -> CryptoMessage -> [Char]
92showCryptoMsg seqno (UpToN PacketRequest bytes) = "UpToN PacketRequest --> " 88showCryptoMsg _ msg = show msg
93 ++ show (PB.decompressSequenceNumbers seqno $ B.unpack bytes)
94showCryptoMsg _ msg = show msg
95 89
96parseCrypto :: (ByteString, SockAddr) -> Either (CryptoPacket Encrypted, SockAddr) (ByteString, SockAddr) 90parseCrypto :: (ByteString, SockAddr) -> Either (CryptoPacket Encrypted, SockAddr) (ByteString, SockAddr)
97parseCrypto (bbs,saddr) = case B.uncons bbs of 91parseCrypto (bbs,saddr) = case B.uncons bbs of
@@ -110,6 +104,7 @@ parseHandshakes bs _ = Left $ "parseHandshakes_:
110encodeHandshakes :: Handshake Encrypted -> SockAddr -> (ByteString, SockAddr) 104encodeHandshakes :: Handshake Encrypted -> SockAddr -> (ByteString, SockAddr)
111encodeHandshakes x saddr = (B.cons 0x1a (runPut $ put x),saddr) 105encodeHandshakes x saddr = (B.cons 0x1a (runPut $ put x),saddr)
112 106
107{-
113createRequestPacket :: Word32 -> [Word32] -> CryptoMessage 108createRequestPacket :: Word32 -> [Word32] -> CryptoMessage
114createRequestPacket seqno xs = let r = UpToN PacketRequest (B.pack ns) 109createRequestPacket 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
129data Handshake (f :: * -> *) = Handshake 125data 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.
262data UserStatus = Online | Away | Busy deriving (Show,Read,Eq,Ord,Enum)
263instance Serialize UserStatus where
264 get = do
265 x <- get :: Get Word8
266 return (toEnum8 x)
267 put x = put (fromEnum8 x)
268
269data TypingStatus = NotTyping | Typing deriving (Show,Read,Eq,Ord,Enum) 246data TypingStatus = NotTyping | Typing deriving (Show,Read,Eq,Ord,Enum)
270instance Serialize TypingStatus where 247instance 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
276unpadCryptoMsg :: CryptoMessage -> CryptoMessage 253unpadCryptoMsg :: CryptoMessage -> CryptoMessage
277unpadCryptoMsg x@(TwoByte Padding (toEnum8 -> mid)) 254unpadCryptoMsg msg@(Pkt Padding :=> Identity (Padded bs)) =
278 | msgSizeParam mid == Just (True,0) = OneByte mid 255 let unpadded = B.dropWhile (== msgbyte Padding) bs
279unpadCryptoMsg 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 257unpadCryptoMsg 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
285unpadCryptoMsg x = x
286 258
287decodeRawCryptoMsg :: CryptoData -> CryptoMessage 259decodeRawCryptoMsg :: CryptoData -> CryptoMessage
288decodeRawCryptoMsg (CryptoData ack seqno cm) = 260decodeRawCryptoMsg (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
294data 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
303msgByteList :: CryptoMessage -> [Word8]
304msgByteList (UpToN _ bs) = B.unpack bs
305msgByteList (TwoByte _ b) = [b]
306msgByteList (OneByte _) = []
307 261
308instance Sized CryptoMessage where 262instance 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
268sizeFor :: Sized x => p x -> Size x
269sizeFor _ = size
270
314 271
315getCryptoMessage :: Word32 -> Get CryptoMessage 272getCryptoMessage :: Word32 -> Get CryptoMessage
316getCryptoMessage seqno = do 273getCryptoMessage 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
327putCryptoMessage :: Word32 -> CryptoMessage -> Put 280putCryptoMessage :: Word32 -> CryptoMessage -> Put
328putCryptoMessage seqno (OneByte i) = putWord8 (fromIntegral . fromEnum $ i) 281putCryptoMessage seqno (Pkt t :=> Identity x) = do
329putCryptoMessage seqno (TwoByte i b) = do putWord8 (fromIntegral . fromEnum $ i) 282 putWord8 (msgbyte t)
330 putWord8 b 283 putPacket seqno x
331putCryptoMessage seqno (UpToN i x) = do putWord8 (fromIntegral . fromEnum $ i) 284
332 putByteString x 285
333putCryptoMessage seqno (RequestResend _ ws) = do
334 putWord8 (fromIntegral . fromEnum $ PacketRequest)
335 mapM_ putWord8 $ compressSequenceNumbers seqno ws
336
337instance Serialize MessageID where
338 get = toEnum . fromIntegral <$> getWord8
339 put x = putWord8 (fromIntegral . fromEnum $ x)
340
341erCompat :: String -> a 286erCompat :: String -> a
342erCompat lens = error $ "Use of '" ++ lens ++ "' lens on incompatible CryptoMessage type" 287erCompat lens = error $ "Use of '" ++ lens ++ "' lens on incompatible CryptoMessage type"
343 288
344typingStatus :: Functor f => (UserStatus -> f UserStatus)-> (CryptoMessage -> f CryptoMessage)
345typingStatus = 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
354userStatus :: Functor f => (UserStatus -> f UserStatus)-> (CryptoMessage -> f CryptoMessage)
355userStatus = 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
362nick :: Functor f => (Text -> f Text)-> (CryptoMessage -> f CryptoMessage)
363nick = 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
370statusMessage :: Functor f => (String -> f String)-> (CryptoMessage -> f CryptoMessage)
371statusMessage = 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
378action :: Functor f => (String -> f String)-> (CryptoMessage -> f CryptoMessage)
379action = 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
386newtype GroupChatId = GrpId ByteString -- 33 bytes 290newtype GroupChatId = GrpId ByteString -- 33 bytes
387 deriving (Show,Eq) 291 deriving (Show,Eq)
@@ -398,9 +302,10 @@ sizedAtLeastN :: Int -> ByteString -> ByteString
398sizedAtLeastN n bs = if B.length bs < n then B.append bs (B.replicate (n - B.length bs) 0) 302sizedAtLeastN 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{-
401instance HasGroupChatID CryptoMessage where 306instance 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
426groupChatID :: (Functor f, HasGroupChatID x) => (GroupChatId -> f GroupChatId) -> (x -> f x) 332groupChatID :: (Functor f, HasGroupChatID x) => (GroupChatId -> f GroupChatId) -> (x -> f x)
427groupChatID = lens getGroupChatID setGroupChatID 333groupChatID = 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{-
437instance HasGroupNumber CryptoMessage where 344instance 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
456groupNumber :: (Functor f, HasGroupNumber x) => (Word16 -> f Word16) -> (x -> f x) 364groupNumber :: (Functor f, HasGroupNumber x) => (Word16 -> f Word16) -> (x -> f x)
457groupNumber = lens getGroupNumber setGroupNumber 365groupNumber = 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{-
463instance HasGroupNumberToJoin CryptoMessage where 372instance 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
476groupNumberToJoin :: (Functor f, HasGroupNumberToJoin x) => (GroupNumber -> f GroupNumber) -> (x -> f x) 386groupNumberToJoin :: (Functor f, HasGroupNumberToJoin x) => (GroupNumber -> f GroupNumber) -> (x -> f x)
477groupNumberToJoin = lens getGroupNumberToJoin setGroupNumberToJoin 387groupNumberToJoin = 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{-
483instance HasPeerNumber CryptoMessage where 394instance 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
496peerNumber :: (Functor f, HasPeerNumber x) => (Word16 -> f Word16) -> (x -> f x) 408peerNumber :: (Functor f, HasPeerNumber x) => (Word16 -> f Word16) -> (x -> f x)
497peerNumber = lens getPeerNumber setPeerNumber 409peerNumber = 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{-
503instance HasMessageNumber CryptoMessage where 416instance 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
516messageNumber :: (Functor f, HasMessageNumber x) => (Word32 -> f Word32) -> (x -> f x) 430messageNumber :: (Functor f, HasMessageNumber x) => (Word32 -> f Word32) -> (x -> f x)
517messageNumber = lens getMessageNumber setMessageNumber 431messageNumber = 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{-
524instance HasMessageName CryptoMessage where 439instance 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
539messageName :: (Functor f, HasMessageName x) => (MessageName -> f MessageName) -> (x -> f x) 455messageName :: (Functor f, HasMessageName x) => (MessageName -> f MessageName) -> (x -> f x)
540messageName = lens getMessageName setMessageName 456messageName = lens getMessageName setMessageName
@@ -542,7 +458,7 @@ messageName = lens getMessageName setMessageName
542data KnownLossyness = KnownLossy | KnownLossless 458data KnownLossyness = KnownLossy | KnownLossless
543 deriving (Eq,Ord,Show,Enum) 459 deriving (Eq,Ord,Show,Enum)
544 460
545data MessageType = Msg MessageID 461data 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
558toEnum8 :: (Enum a, Integral word8) => word8 -> a
559toEnum8 = toEnum . fromIntegral
560fromEnum8 :: Enum a => a -> Word8
561fromEnum8 = fromIntegral . fromEnum
562
563fromEnum16 :: Enum a => a -> Word16 474fromEnum16 :: Enum a => a -> Word16
564fromEnum16 = fromIntegral . fromEnum 475fromEnum16 = 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{-
602instance HasMessageType CryptoMessage where 514instance 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{-
623instance HasMessageType CryptoData where 537instance 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
628messageType :: (Functor f, HasMessageType x) => (MessageType -> f MessageType) -> (x -> f x) 543messageType :: (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{-
637instance HasMessageData CryptoMessage where 553instance 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
653messageData :: (Functor f, HasMessageData x) => (MessageData -> f MessageData) -> (x -> f x) 570messageData :: (Functor f, HasMessageData x) => (MessageData -> f MessageData) -> (x -> f x)
654messageData = lens getMessageData setMessageData 571messageData = 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{-
660instance HasTitle CryptoMessage where 578instance 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
681title :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x) 600title :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x)
682title = lens getTitle setTitle 601title = 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{-
693instance HasMessage CryptoMessage where 613instance 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
710message :: (Functor f, HasMessage x) => (Text -> f Text) -> (x -> f x) 630message :: (Functor f, HasMessage x) => (Text -> f Text) -> (x -> f x)
711message = lens getMessage setMessage 631message = 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{-
718instance HasName CryptoMessage where 639instance 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
728name :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x) 650name :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x)
729name = lens getTitle setTitle 651name = 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{-
774leaveMsg, peerQueryMsg :: Serialize a => a -> CryptoMessage 699leaveMsg, peerQueryMsg :: Serialize a => a -> CryptoMessage
775leaveMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x01) 700leaveMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x01)
776peerQueryMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x08) 701peerQueryMsg 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
797msgSizeParam MESSAGE_GROUPCHAT {-0x63-} = Nothing -- variable 723msgSizeParam MESSAGE_GROUPCHAT {-0x63-} = Nothing -- variable
798msgSizeParam LOSSY_GROUPCHAT {-0xC7-} = Nothing -- variable 724msgSizeParam LOSSY_GROUPCHAT {-0xC7-} = Nothing -- variable
799msgSizeParam _ = Nothing 725msgSizeParam _ = Nothing
726-}
800 727
801isIndirectGrpChat :: MessageID -> Bool 728isIndirectGrpChat :: Msg n t -> Bool
802isIndirectGrpChat MESSAGE_GROUPCHAT = True 729isIndirectGrpChat MESSAGE_CONFERENCE = True
803isIndirectGrpChat LOSSY_GROUPCHAT = True 730isIndirectGrpChat LOSSY_CONFERENCE = True
804isIndirectGrpChat _ = False 731isIndirectGrpChat _ = False
805 732
806isKillPacket :: MessageType -> Bool 733isKillPacket :: SomeMsg -> Bool
807isKillPacket (Msg KillPacket) = True 734isKillPacket (M KillPacket) = True
808isKillPacket _ = False 735isKillPacket _ = False
809 736
810isOFFLINE :: MessageType -> Bool 737isOFFLINE :: SomeMsg -> Bool
811isOFFLINE (Msg OFFLINE) = True 738isOFFLINE (M OFFLINE) = True
812isOFFLINE _ = False 739isOFFLINE _ = False
813 740
814 741
815data MessageName = Ping -- 0x00 742data MessageName = Ping -- 0x00