summaryrefslogtreecommitdiff
path: root/src/Network/Tox
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/Tox')
-rw-r--r--src/Network/Tox/Crypto/Transport.hs273
1 files changed, 74 insertions, 199 deletions
diff --git a/src/Network/Tox/Crypto/Transport.hs b/src/Network/Tox/Crypto/Transport.hs
index 1c641584..b79334d7 100644
--- a/src/Network/Tox/Crypto/Transport.hs
+++ b/src/Network/Tox/Crypto/Transport.hs
@@ -1,10 +1,11 @@
1{-# LANGUAGE KindSignatures #-} 1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE NamedFieldPuns #-} 2{-# LANGUAGE KindSignatures #-}
3{-# LANGUAGE ViewPatterns #-} 3{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE FlexibleInstances #-} 4{-# LANGUAGE NamedFieldPuns #-}
5{-# LANGUAGE LambdaCase #-} 5{-# LANGUAGE PatternSynonyms #-}
6{-# LANGUAGE TupleSections #-}
7{-# LANGUAGE StandaloneDeriving #-} 6{-# LANGUAGE StandaloneDeriving #-}
7{-# LANGUAGE TupleSections #-}
8{-# LANGUAGE ViewPatterns #-}
8module Network.Tox.Crypto.Transport 9module Network.Tox.Crypto.Transport
9 ( showCryptoMsg 10 ( showCryptoMsg
10 , parseCrypto 11 , parseCrypto
@@ -21,7 +22,7 @@ module Network.Tox.Crypto.Transport
21 , HandshakeData(..) 22 , HandshakeData(..)
22 , Handshake(..) 23 , Handshake(..)
23 , PeerInfo(..) 24 , PeerInfo(..)
24 , MessageID(..) 25 , module Data.Tox.Message
25 , UserStatus(..) 26 , UserStatus(..)
26 , TypingStatus(..) 27 , TypingStatus(..)
27 , GroupChatId(..) 28 , GroupChatId(..)
@@ -53,13 +54,10 @@ module Network.Tox.Crypto.Transport
53 , sizedN 54 , sizedN
54 , sizedAtLeastN 55 , sizedAtLeastN
55 , isIndirectGrpChat 56 , isIndirectGrpChat
56 , LossyOrLossless(..)
57 , fromEnum8 57 , fromEnum8
58 , fromEnum16 58 , fromEnum16
59 , toEnum8 59 , toEnum8
60 , msgSizeParam 60 , msgSizeParam
61 , NegotiationID(..)
62 , NegotiationMsg(..)
63 , getCryptoMessage 61 , getCryptoMessage
64 , putCryptoMessage 62 , putCryptoMessage
65 , module Data.Tox.Message 63 , module Data.Tox.Message
@@ -96,10 +94,11 @@ showCryptoMsg seqno (UpToN PacketRequest bytes) = "UpToN PacketRequest --> "
96showCryptoMsg _ msg = show msg 94showCryptoMsg _ msg = show msg
97 95
98parseCrypto :: (ByteString, SockAddr) -> Either (CryptoPacket Encrypted, SockAddr) (ByteString, SockAddr) 96parseCrypto :: (ByteString, SockAddr) -> Either (CryptoPacket Encrypted, SockAddr) (ByteString, SockAddr)
99parseCrypto ((B.uncons -> Just (0x1b,pkt)),saddr) = either (\_ -> Right (pkt,saddr)) 97parseCrypto (bbs,saddr) = case B.uncons bbs of
100 (\x -> Left (x ,saddr)) 98 Just (0x1b,bs) -> case runGet get bs of
101 $ runGet get pkt 99 Right pkt -> Left (pkt, saddr) -- Successful parse, handle this packet.
102parseCrypto not_mine = Right not_mine 100 Left _ -> Right (bs,saddr) -- Failed parse, strip first byte and pass it on.
101 _ -> Right (bbs,saddr) -- Type-code mismatch, pass it on.
103 102
104encodeCrypto :: (CryptoPacket Encrypted, SockAddr) -> Maybe (ByteString, SockAddr) 103encodeCrypto :: (CryptoPacket Encrypted, SockAddr) -> Maybe (ByteString, SockAddr)
105encodeCrypto (x,saddr) = Just (B.cons 0x1b (runPut $ put x),saddr) 104encodeCrypto (x,saddr) = Just (B.cons 0x1b (runPut $ put x),saddr)
@@ -659,15 +658,24 @@ class HasTitle x where
659 setTitle :: x -> Text -> x 658 setTitle :: x -> Text -> x
660 659
661instance HasTitle CryptoMessage where 660instance HasTitle CryptoMessage where
662 getTitle (UpToN DIRECT_GROUPCHAT {-Ox62-} (sizedAtLeastN 3 -> B.splitAt 2 -> (_,B.uncons -> Just (0x0a,mdata)))) = decodeUtf8 mdata 661 getTitle (UpToN xE bs)
663 getTitle (UpToN xE (sizedAtLeastN 9 -> B.splitAt 8 -> (_,B.uncons -> Just (toEnum . fromIntegral -> GroupchatTitleChange,mdata)))) 662 | DIRECT_GROUPCHAT {-0x62-} <- xE,
664 | isIndirectGrpChat xE = decodeUtf8 mdata 663 (_,0x0a,mdata) <- splitByteAt 2 bs = decodeUtf8 mdata
665 getTitle _ = error "getTitle on CryptoMessage without title field." 664 | isIndirectGrpChat xE,
666 665 let (_,nmb,mdata) = splitByteAt 8 bs
667 setTitle (UpToN xE@DIRECT_GROUPCHAT {-0x62-} (sizedAtLeastN 3 -> B.splitAt 2 -> (bs,B.uncons -> Just (_,xs)))) messagedata 666 nm = toEnum (fromIntegral nmb),
668 = UpToN xE (B.concat [bs,B.cons 0x0a (encodeUtf8 messagedata)]) 667 GroupchatTitleChange <- nm = decodeUtf8 mdata
669 setTitle (UpToN xE (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,B.uncons -> Just (_,xs)))) title 668 getTitle _ = error "getTitle on CryptoMessage without title field."
670 | isIndirectGrpChat xE = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum GroupchatTitleChange) (encodeUtf8 title)]) 669
670 setTitle (UpToN xE bs) msgdta
671 | DIRECT_GROUPCHAT {-0x62-} <- xE
672 = let (pre,_,_) = splitByteAt 2 bs
673 nm = 0x0a
674 in UpToN xE (pre <> B.cons nm (encodeUtf8 msgdta))
675 | isIndirectGrpChat xE
676 = let (pre,_,_) = splitByteAt 8 bs
677 nm = fromIntegral $ fromEnum GroupchatTitleChange
678 in UpToN xE (pre <> B.cons nm (encodeUtf8 msgdta))
671 setTitle _ _ = error "setTitle on CryptoMessage without title field." 679 setTitle _ _ = error "setTitle on CryptoMessage without title field."
672 680
673title :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x) 681title :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x)
@@ -677,17 +685,28 @@ class HasMessage x where
677 getMessage :: x -> Text 685 getMessage :: x -> Text
678 setMessage :: x -> Text -> x 686 setMessage :: x -> Text -> x
679 687
688splitByteAt :: Int -> ByteString -> (ByteString,Word8,ByteString)
689splitByteAt n bs = (fixed,w8,bs')
690 where
691 (fixed,B.uncons -> Just (w8,bs')) = B.splitAt n $ sizedAtLeastN (n+1) bs
692
680instance HasMessage CryptoMessage where 693instance HasMessage CryptoMessage where
681 getMessage (UpToN MESSAGE bstr) = T.decodeUtf8 bstr 694 getMessage (UpToN xE bs)
682 getMessage (UpToN xE (sizedAtLeastN 9 -> B.splitAt 8 -> (_,B.uncons -> Just (mnameByte,mdata)))) 695 | MESSAGE <- xE = T.decodeUtf8 bs
683 | isIndirectGrpChat xE = decodeUtf8 mdata 696 | isIndirectGrpChat xE = T.decodeUtf8 mdata where (_,_,mdata) = splitByteAt 8 bs
684 getMessage _ = error "getMessage on CryptoMessage without message field." 697 getMessage _ = error "getMessage on CryptoMessage without message field."
685 698
686 setMessage (UpToN MESSAGE _) message = UpToN MESSAGE (T.encodeUtf8 $ message) 699 setMessage (UpToN xE bs) message
687 setMessage (UpToN xE (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,B.uncons -> Just (mnameByte,xs)))) message 700 | MESSAGE <- xE
688 | isIndirectGrpChat xE = UpToN xE (B.concat [bs,B.cons (if mnameByte == 0 then 0x40 else mnameByte) (encodeUtf8 message)]) 701 = UpToN xE $ T.encodeUtf8 message
702 | isIndirectGrpChat xE
703 = let (pre8,nm0,xs) = splitByteAt 8 bs
704 nm = if nm0 == 0 then 0x40 else nm0
705 prefix x = pre8 <> B.cons nm x
706 in UpToN xE $ prefix $ T.encodeUtf8 message
689 setMessage _ _ = error "setMessage on CryptoMessage without message field." 707 setMessage _ _ = error "setMessage on CryptoMessage without message field."
690 708
709
691message :: (Functor f, HasMessage x) => (Text -> f Text) -> (x -> f x) 710message :: (Functor f, HasMessage x) => (Text -> f Text) -> (x -> f x)
692message = lens getMessage setMessage 711message = lens getMessage setMessage
693 712
@@ -714,7 +733,7 @@ data PeerInfo
714 { piPeerNum :: PeerNumber 733 { piPeerNum :: PeerNumber
715 , piUserKey :: PublicKey 734 , piUserKey :: PublicKey
716 , piDHTKey :: PublicKey 735 , piDHTKey :: PublicKey
717 , piName :: ByteString -- byte-prefix for length 736 , piName :: ByteString -- byte-prefix for length
718 } deriving (Eq,Show) 737 } deriving (Eq,Show)
719 738
720instance HasPeerNumber PeerInfo where 739instance HasPeerNumber PeerInfo where
@@ -747,15 +766,13 @@ instance Serialize PeerInfo where
747-- > userStatus .~ Busy $ msg USERSTATUS 766-- > userStatus .~ Busy $ msg USERSTATUS
748-- 767--
749msg :: MessageID -> CryptoMessage 768msg :: MessageID -> CryptoMessage
750msg mid | Just (True,0) <- msgSizeParam mid = OneByte mid 769msg mid | Just (True,0) <- msgSizeParam mid = OneByte mid
751msg mid | Just (True,1) <- msgSizeParam mid = TwoByte mid 0 770 | Just (True,1) <- msgSizeParam mid = TwoByte mid 0
752msg mid | Just (False,_) <- msgSizeParam mid = UpToN mid B.empty 771 | Just (False,_) <- msgSizeParam mid = UpToN mid B.empty
753msg mid = UpToN mid B.empty 772 | otherwise = UpToN mid B.empty
754 773
755leaveMsg :: Serialize a => a -> CryptoMessage 774leaveMsg, peerQueryMsg :: Serialize a => a -> CryptoMessage
756leaveMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x01) 775leaveMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x01)
757
758peerQueryMsg :: Serialize a => a -> CryptoMessage
759peerQueryMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x08) 776peerQueryMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x08)
760 777
761 778
@@ -763,39 +780,36 @@ peerQueryMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x08)
763-- the maximum allowed size for the message Payload (message minus id) 780-- the maximum allowed size for the message Payload (message minus id)
764-- Or Nothing if unknown/unimplemented. 781-- Or Nothing if unknown/unimplemented.
765msgSizeParam :: MessageID -> Maybe (Bool,Int) 782msgSizeParam :: MessageID -> Maybe (Bool,Int)
766msgSizeParam ONLINE = Just (True,0) 783msgSizeParam ONLINE = Just (True ,0)
767msgSizeParam OFFLINE = Just (True,0) 784msgSizeParam OFFLINE = Just (True ,0)
768msgSizeParam USERSTATUS = Just (True,1) 785msgSizeParam USERSTATUS = Just (True ,1)
769msgSizeParam TYPING = Just (True,1) 786msgSizeParam TYPING = Just (True ,1)
770msgSizeParam NICKNAME = Just (False,128) 787msgSizeParam NICKNAME = Just (False,128)
771msgSizeParam STATUSMESSAGE = Just (False,1007) 788msgSizeParam STATUSMESSAGE = Just (False,1007)
772msgSizeParam MESSAGE = Just (False,1372) 789msgSizeParam MESSAGE = Just (False,1372)
773msgSizeParam ACTION = Just (False,1372) 790msgSizeParam ACTION = Just (False,1372)
774msgSizeParam FILE_DATA = Just (False,1372)-- up to 1373 791msgSizeParam FILE_DATA = Just (False,1372)-- up to 1373
775msgSizeParam FILE_SENDREQUEST = Just (False,300) -- 1+1+4+8+32+max255 = up to 301 792msgSizeParam FILE_SENDREQUEST = Just (False,300) -- 1+1+4+8+32+max255 = up to 301
776msgSizeParam FILE_CONTROL = Just (False,7) -- 8 bytes if seek, otherwise 4 793msgSizeParam FILE_CONTROL = Just (False,7) -- 8 bytes if seek, otherwise 4
777msgSizeParam INVITE_GROUPCHAT = Just (False,38) 794msgSizeParam INVITE_GROUPCHAT = Just (False,38)
778msgSizeParam ONLINE_PACKET = Just (True,35) 795msgSizeParam ONLINE_PACKET = Just (True ,35)
779msgSizeParam DIRECT_GROUPCHAT {-0x62-} = Nothing -- 1+2+1 thus Just (True,3) leave & peer-query, but variable in response packets 796msgSizeParam DIRECT_GROUPCHAT {-0x62-} = Nothing -- 1+2+1 thus Just (True,3) leave & peer-query, but variable in response packets
780msgSizeParam MESSAGE_GROUPCHAT {-0x63-} = Nothing -- variable 797msgSizeParam MESSAGE_GROUPCHAT {-0x63-} = Nothing -- variable
781msgSizeParam LOSSY_GROUPCHAT {-0xC7-} = Nothing -- variable 798msgSizeParam LOSSY_GROUPCHAT {-0xC7-} = Nothing -- variable
782msgSizeParam _ = Nothing 799msgSizeParam _ = Nothing
783 800
784isIndirectGrpChat :: MessageID -> Bool 801isIndirectGrpChat :: MessageID -> Bool
785isIndirectGrpChat MESSAGE_GROUPCHAT = True 802isIndirectGrpChat MESSAGE_GROUPCHAT = True
786isIndirectGrpChat LOSSY_GROUPCHAT = True 803isIndirectGrpChat LOSSY_GROUPCHAT = True
787isIndirectGrpChat _ = False 804isIndirectGrpChat _ = False
788
789 805
790isKillPacket :: MessageType -> Bool 806isKillPacket :: MessageType -> Bool
791isKillPacket (Msg KillPacket) = True 807isKillPacket (Msg KillPacket) = True
792isKillPacket _ = False 808isKillPacket _ = False
793 809
794isOFFLINE :: MessageType -> Bool 810isOFFLINE :: MessageType -> Bool
795isOFFLINE (Msg OFFLINE) = True 811isOFFLINE (Msg OFFLINE) = True
796isOFFLINE _ = False 812isOFFLINE _ = False
797
798
799 813
800 814
801data MessageName = Ping -- 0x00 815data MessageName = Ping -- 0x00
@@ -1056,142 +1070,3 @@ data MessageName = Ping -- 0x00
1056 | MessageName0xff 1070 | MessageName0xff
1057 deriving (Show,Eq,Ord,Enum,Bounded) 1071 deriving (Show,Eq,Ord,Enum,Bounded)
1058 1072
1059-- --> CookieRequest WithoutCookie
1060-- <-- CookieResponse CookieAddress
1061-- --> Handshake CookieAddress
1062-- <-- Handshake CookieAddress
1063
1064-- cookie request packet (145 bytes)
1065--
1066-- [uint8_t 24]
1067-- [Sender's DHT Public key (32 bytes)]
1068-- [Random nonce (24 bytes)]
1069-- [Encrypted message containing:
1070-- [Sender's real public key (32 bytes)]
1071-- [padding (32 bytes)]
1072-- [uint64_t echo id (must be sent back untouched in cookie response)]
1073-- ]
1074
1075
1076-- cookie response packet (161 bytes):
1077--
1078-- [uint8_t 25]
1079-- [Random nonce (24 bytes)]
1080-- [Encrypted message containing:
1081-- [Cookie]
1082-- [uint64_t echo id (that was sent in the request)]
1083-- ]
1084--
1085-- Encrypted message is encrypted with the exact same symmetric key as the
1086-- cookie request packet it responds to but with a different nonce.
1087-- (Encrypted message is encrypted with reqesters's DHT private key,
1088-- responders's DHT public key and the nonce.)
1089--
1090-- Since we don't receive the public key, we will need to lookup the key by
1091-- the SockAddr... I don't understand why the CookieResponse message is
1092-- special this way. TODO: implement a multimap (SockAddr -> SharedSecret)
1093-- and wrap cookie queries with store/delete. TODO: Should the entire
1094-- SharedScret cache be keyed on only SockAddr ? Perhaps the secret cache
1095-- should be (NodeId -> Secret) and the cookie-request map should be
1096-- (SockAddr -> NodeId)
1097
1098
1099-----------------------------------------------------------
1100-- Session feature negotiation, piggy back on AlivePacket(PING)
1101--
1102-- UpToN { msgID = PING{-16-}
1103-- , msgBytes = S.encode (UpToN { msgID = toEnum8 (fromEnum8 NegotiationID)
1104-- , msgBytes = payload
1105-- })
1106--
1107--
1108-- RefInfo = { Word32 -- this messsage (refnum), start with 1
1109-- , Word32 -- 0 if not replying, otherwise refnum of message it is in reply too
1110-- }
1111--
1112-- position = { Word8 -- 0 = top (MessageID) level, 1 = MessageName level
1113-- , Word8 -- MessageID
1114-- }
1115-- all MessageName-level messages use MESSAGE_GROUPCHAT as their primary Id
1116data NegotiationID -- payload --
1117 = DefineTopLevel -- Word8(NegotiationID)Word64(RefInfo):Word64(msg-type),Word16-position,Word64-type,Word24-position ...
1118 -- ^ Inform remote of your top-level map
1119 | DefineMap -- Word8(NegotiationID)Word64(RefInfo):Word32(map-num),Word16-position,Word64-type,Word24-position,Word64(msg-type), ...
1120 -- ^ Inform remote of available user-selectable second-level map
1121 | AnnounceSelectedMap -- Word8(NegotiationID)Word64(RefInfo):Word32(map-num)
1122 -- ^ Inform remote which second-level map he currently has selected
1123 | RequestMap -- Word8(NegotiationID)Word64(RefInfo):Word16-position,Word64-type,Word16-position,Word64(msg-type) ...
1124 -- ^ Ask remote for a selectable map supporting the message types at specific locations
1125 | SelectMap -- Word8(NegotiationID)Word64(RefInfo):Word32(map-num)
1126 -- ^ Tell remote which secondary map to use while interpretting your messages
1127 | DiscardMap -- Word8(NegotiationID)Word64(RefInfo):Word32(map-num)
1128 -- ^ Tell remote you aren't going to use the specified secondary map
1129 | DenyRequest -- Word8(NegotiationID)Word64(RefInfo)
1130 -- ^ Inform remote that you opted not to comply with his request (or selection), or there was some error
1131 deriving (Show,Eq,Ord,Enum,Bounded)
1132
1133instance Serialize NegotiationID where
1134 get = toEnum . fromIntegral <$> getWord8
1135 put x = putWord8 (fromIntegral . fromEnum $ x)
1136
1137data NegotiationMsg
1138 = NegMsg { negID :: NegotiationID
1139 , negNum :: Word32
1140 , negRef :: Word32
1141 , negMapNum :: Maybe Word32
1142 , negRange :: [((Word8,Word8),Word64)]
1143 } deriving (Eq,Show)
1144
1145instance Sized NegotiationMsg where
1146 size = VarSize $ \case
1147 x | negID x == DenyRequest -> 9
1148 x | negID x `Prelude.elem` [SelectMap,DiscardMap,AnnounceSelectedMap]
1149 -> 10
1150 x | negID x `Prelude.elem` [DefineTopLevel,RequestMap]
1151 , xs <- negRange x -> 9 + 10 * (Prelude.length xs)
1152
1153 x | negID x == DefineMap
1154 , xs <- negRange x -> 13 + 10 * (Prelude.length xs)
1155
1156instance Serialize NegotiationMsg where
1157 get = do
1158 i <- get :: Get NegotiationID
1159 num <- getWord32le :: Get Word32
1160 ref <- getWord32le :: Get Word32
1161 let getRangeReversed = flip fix [] $ \loop xs -> do
1162 emp <- isEmpty
1163 if emp then return xs
1164 else do
1165 level <- get :: Get Word8
1166 id <- get :: Get Word8
1167 typ <- getWord64le :: Get Word64
1168 loop (((level,id),typ):xs)
1169 let getRange = Prelude.reverse <$> getRangeReversed
1170 (mapNum,range)
1171 <- case i of
1172 x | x `Prelude.elem` [SelectMap,DiscardMap,AnnounceSelectedMap]
1173 -> do
1174 mapNum <- getWord32le :: Get Word32
1175 return (Just mapNum,[])
1176 x | x `Prelude.elem` [DefineTopLevel,RequestMap]
1177 -> do
1178 xs <- getRange
1179 return (Nothing,xs)
1180 DefineMap -> do
1181 mapNum <- getWord32le :: Get Word32
1182 xs <- getRange
1183 return (Just mapNum,xs)
1184
1185 _ -> return (Nothing,[])
1186 return $ NegMsg i num ref mapNum range
1187
1188 put msg = do
1189 putWord8 (fromIntegral . fromEnum $ negID msg)
1190 putWord32le (negNum msg)
1191 putWord32le (negRef msg)
1192 maybe (return ()) putWord32le (negMapNum msg)
1193 forM_ (negRange msg) $ \((lvl,id),typ) -> do
1194 putWord8 lvl
1195 putWord8 id
1196 putWord64le typ
1197