From 6ab923f538f0a090e09da37154d5ce0fbe657dac Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sat, 8 Sep 2018 06:41:08 -0400 Subject: Clean-up. --- src/Network/Tox/Crypto/Transport.hs | 273 ++++++++++-------------------------- 1 file changed, 74 insertions(+), 199 deletions(-) (limited to 'src/Network/Tox') 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 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} module Network.Tox.Crypto.Transport ( showCryptoMsg , parseCrypto @@ -21,7 +22,7 @@ module Network.Tox.Crypto.Transport , HandshakeData(..) , Handshake(..) , PeerInfo(..) - , MessageID(..) + , module Data.Tox.Message , UserStatus(..) , TypingStatus(..) , GroupChatId(..) @@ -53,13 +54,10 @@ module Network.Tox.Crypto.Transport , sizedN , sizedAtLeastN , isIndirectGrpChat - , LossyOrLossless(..) , fromEnum8 , fromEnum16 , toEnum8 , msgSizeParam - , NegotiationID(..) - , NegotiationMsg(..) , getCryptoMessage , putCryptoMessage , module Data.Tox.Message @@ -96,10 +94,11 @@ showCryptoMsg seqno (UpToN PacketRequest bytes) = "UpToN PacketRequest --> " showCryptoMsg _ msg = show msg parseCrypto :: (ByteString, SockAddr) -> Either (CryptoPacket Encrypted, SockAddr) (ByteString, SockAddr) -parseCrypto ((B.uncons -> Just (0x1b,pkt)),saddr) = either (\_ -> Right (pkt,saddr)) - (\x -> Left (x ,saddr)) - $ runGet get pkt -parseCrypto not_mine = Right not_mine +parseCrypto (bbs,saddr) = case B.uncons bbs of + Just (0x1b,bs) -> case runGet get bs of + Right pkt -> Left (pkt, saddr) -- Successful parse, handle this packet. + Left _ -> Right (bs,saddr) -- Failed parse, strip first byte and pass it on. + _ -> Right (bbs,saddr) -- Type-code mismatch, pass it on. encodeCrypto :: (CryptoPacket Encrypted, SockAddr) -> Maybe (ByteString, SockAddr) encodeCrypto (x,saddr) = Just (B.cons 0x1b (runPut $ put x),saddr) @@ -659,15 +658,24 @@ class HasTitle x where setTitle :: x -> Text -> x instance HasTitle CryptoMessage where - getTitle (UpToN DIRECT_GROUPCHAT {-Ox62-} (sizedAtLeastN 3 -> B.splitAt 2 -> (_,B.uncons -> Just (0x0a,mdata)))) = decodeUtf8 mdata - getTitle (UpToN xE (sizedAtLeastN 9 -> B.splitAt 8 -> (_,B.uncons -> Just (toEnum . fromIntegral -> GroupchatTitleChange,mdata)))) - | isIndirectGrpChat xE = decodeUtf8 mdata - getTitle _ = error "getTitle on CryptoMessage without title field." - - setTitle (UpToN xE@DIRECT_GROUPCHAT {-0x62-} (sizedAtLeastN 3 -> B.splitAt 2 -> (bs,B.uncons -> Just (_,xs)))) messagedata - = UpToN xE (B.concat [bs,B.cons 0x0a (encodeUtf8 messagedata)]) - setTitle (UpToN xE (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,B.uncons -> Just (_,xs)))) title - | isIndirectGrpChat xE = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum GroupchatTitleChange) (encodeUtf8 title)]) + getTitle (UpToN xE bs) + | DIRECT_GROUPCHAT {-0x62-} <- xE, + (_,0x0a,mdata) <- splitByteAt 2 bs = decodeUtf8 mdata + | isIndirectGrpChat xE, + let (_,nmb,mdata) = splitByteAt 8 bs + nm = toEnum (fromIntegral nmb), + GroupchatTitleChange <- nm = decodeUtf8 mdata + getTitle _ = error "getTitle on CryptoMessage without title field." + + setTitle (UpToN xE bs) msgdta + | DIRECT_GROUPCHAT {-0x62-} <- xE + = let (pre,_,_) = splitByteAt 2 bs + nm = 0x0a + in UpToN xE (pre <> B.cons nm (encodeUtf8 msgdta)) + | isIndirectGrpChat xE + = let (pre,_,_) = splitByteAt 8 bs + nm = fromIntegral $ fromEnum GroupchatTitleChange + in UpToN xE (pre <> B.cons nm (encodeUtf8 msgdta)) setTitle _ _ = error "setTitle on CryptoMessage without title field." title :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x) @@ -677,17 +685,28 @@ class HasMessage x where getMessage :: x -> Text setMessage :: x -> Text -> x +splitByteAt :: Int -> ByteString -> (ByteString,Word8,ByteString) +splitByteAt n bs = (fixed,w8,bs') + where + (fixed,B.uncons -> Just (w8,bs')) = B.splitAt n $ sizedAtLeastN (n+1) bs + instance HasMessage CryptoMessage where - getMessage (UpToN MESSAGE bstr) = T.decodeUtf8 bstr - getMessage (UpToN xE (sizedAtLeastN 9 -> B.splitAt 8 -> (_,B.uncons -> Just (mnameByte,mdata)))) - | isIndirectGrpChat xE = decodeUtf8 mdata - getMessage _ = error "getMessage on CryptoMessage without message field." - - setMessage (UpToN MESSAGE _) message = UpToN MESSAGE (T.encodeUtf8 $ message) - setMessage (UpToN xE (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,B.uncons -> Just (mnameByte,xs)))) message - | isIndirectGrpChat xE = UpToN xE (B.concat [bs,B.cons (if mnameByte == 0 then 0x40 else mnameByte) (encodeUtf8 message)]) + getMessage (UpToN xE bs) + | MESSAGE <- xE = T.decodeUtf8 bs + | isIndirectGrpChat xE = T.decodeUtf8 mdata where (_,_,mdata) = splitByteAt 8 bs + getMessage _ = error "getMessage on CryptoMessage without message field." + + setMessage (UpToN xE bs) message + | MESSAGE <- xE + = UpToN xE $ T.encodeUtf8 message + | isIndirectGrpChat xE + = let (pre8,nm0,xs) = splitByteAt 8 bs + nm = if nm0 == 0 then 0x40 else nm0 + prefix x = pre8 <> B.cons nm x + in UpToN xE $ prefix $ T.encodeUtf8 message setMessage _ _ = error "setMessage on CryptoMessage without message field." + message :: (Functor f, HasMessage x) => (Text -> f Text) -> (x -> f x) message = lens getMessage setMessage @@ -714,7 +733,7 @@ data PeerInfo { piPeerNum :: PeerNumber , piUserKey :: PublicKey , piDHTKey :: PublicKey - , piName :: ByteString -- byte-prefix for length + , piName :: ByteString -- byte-prefix for length } deriving (Eq,Show) instance HasPeerNumber PeerInfo where @@ -747,15 +766,13 @@ instance Serialize PeerInfo where -- > userStatus .~ Busy $ msg USERSTATUS -- msg :: MessageID -> CryptoMessage -msg mid | Just (True,0) <- msgSizeParam mid = OneByte mid -msg mid | Just (True,1) <- msgSizeParam mid = TwoByte mid 0 -msg mid | Just (False,_) <- msgSizeParam mid = UpToN mid B.empty -msg mid = UpToN mid B.empty +msg mid | Just (True,0) <- msgSizeParam mid = OneByte mid + | Just (True,1) <- msgSizeParam mid = TwoByte mid 0 + | Just (False,_) <- msgSizeParam mid = UpToN mid B.empty + | otherwise = UpToN mid B.empty -leaveMsg :: Serialize a => a -> CryptoMessage +leaveMsg, peerQueryMsg :: Serialize a => a -> CryptoMessage leaveMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x01) - -peerQueryMsg :: Serialize a => a -> CryptoMessage peerQueryMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x08) @@ -763,39 +780,36 @@ peerQueryMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x08) -- the maximum allowed size for the message Payload (message minus id) -- Or Nothing if unknown/unimplemented. msgSizeParam :: MessageID -> Maybe (Bool,Int) -msgSizeParam ONLINE = Just (True,0) -msgSizeParam OFFLINE = Just (True,0) -msgSizeParam USERSTATUS = Just (True,1) -msgSizeParam TYPING = Just (True,1) -msgSizeParam NICKNAME = Just (False,128) -msgSizeParam STATUSMESSAGE = Just (False,1007) -msgSizeParam MESSAGE = Just (False,1372) -msgSizeParam ACTION = Just (False,1372) -msgSizeParam FILE_DATA = Just (False,1372)-- up to 1373 -msgSizeParam FILE_SENDREQUEST = Just (False,300) -- 1+1+4+8+32+max255 = up to 301 -msgSizeParam FILE_CONTROL = Just (False,7) -- 8 bytes if seek, otherwise 4 -msgSizeParam INVITE_GROUPCHAT = Just (False,38) -msgSizeParam ONLINE_PACKET = Just (True,35) +msgSizeParam ONLINE = Just (True ,0) +msgSizeParam OFFLINE = Just (True ,0) +msgSizeParam USERSTATUS = Just (True ,1) +msgSizeParam TYPING = Just (True ,1) +msgSizeParam NICKNAME = Just (False,128) +msgSizeParam STATUSMESSAGE = Just (False,1007) +msgSizeParam MESSAGE = Just (False,1372) +msgSizeParam ACTION = Just (False,1372) +msgSizeParam FILE_DATA = Just (False,1372)-- up to 1373 +msgSizeParam FILE_SENDREQUEST = Just (False,300) -- 1+1+4+8+32+max255 = up to 301 +msgSizeParam FILE_CONTROL = Just (False,7) -- 8 bytes if seek, otherwise 4 +msgSizeParam INVITE_GROUPCHAT = Just (False,38) +msgSizeParam ONLINE_PACKET = Just (True ,35) msgSizeParam DIRECT_GROUPCHAT {-0x62-} = Nothing -- 1+2+1 thus Just (True,3) leave & peer-query, but variable in response packets msgSizeParam MESSAGE_GROUPCHAT {-0x63-} = Nothing -- variable msgSizeParam LOSSY_GROUPCHAT {-0xC7-} = Nothing -- variable -msgSizeParam _ = Nothing +msgSizeParam _ = Nothing isIndirectGrpChat :: MessageID -> Bool isIndirectGrpChat MESSAGE_GROUPCHAT = True -isIndirectGrpChat LOSSY_GROUPCHAT = True -isIndirectGrpChat _ = False - +isIndirectGrpChat LOSSY_GROUPCHAT = True +isIndirectGrpChat _ = False isKillPacket :: MessageType -> Bool isKillPacket (Msg KillPacket) = True -isKillPacket _ = False +isKillPacket _ = False isOFFLINE :: MessageType -> Bool isOFFLINE (Msg OFFLINE) = True -isOFFLINE _ = False - - +isOFFLINE _ = False data MessageName = Ping -- 0x00 @@ -1056,142 +1070,3 @@ data MessageName = Ping -- 0x00 | MessageName0xff deriving (Show,Eq,Ord,Enum,Bounded) --- --> CookieRequest WithoutCookie --- <-- CookieResponse CookieAddress --- --> Handshake CookieAddress --- <-- Handshake CookieAddress - --- cookie request packet (145 bytes) --- --- [uint8_t 24] --- [Sender's DHT Public key (32 bytes)] --- [Random nonce (24 bytes)] --- [Encrypted message containing: --- [Sender's real public key (32 bytes)] --- [padding (32 bytes)] --- [uint64_t echo id (must be sent back untouched in cookie response)] --- ] - - --- cookie response packet (161 bytes): --- --- [uint8_t 25] --- [Random nonce (24 bytes)] --- [Encrypted message containing: --- [Cookie] --- [uint64_t echo id (that was sent in the request)] --- ] --- --- Encrypted message is encrypted with the exact same symmetric key as the --- cookie request packet it responds to but with a different nonce. --- (Encrypted message is encrypted with reqesters's DHT private key, --- responders's DHT public key and the nonce.) --- --- Since we don't receive the public key, we will need to lookup the key by --- the SockAddr... I don't understand why the CookieResponse message is --- special this way. TODO: implement a multimap (SockAddr -> SharedSecret) --- and wrap cookie queries with store/delete. TODO: Should the entire --- SharedScret cache be keyed on only SockAddr ? Perhaps the secret cache --- should be (NodeId -> Secret) and the cookie-request map should be --- (SockAddr -> NodeId) - - ------------------------------------------------------------ --- Session feature negotiation, piggy back on AlivePacket(PING) --- --- UpToN { msgID = PING{-16-} --- , msgBytes = S.encode (UpToN { msgID = toEnum8 (fromEnum8 NegotiationID) --- , msgBytes = payload --- }) --- --- --- RefInfo = { Word32 -- this messsage (refnum), start with 1 --- , Word32 -- 0 if not replying, otherwise refnum of message it is in reply too --- } --- --- position = { Word8 -- 0 = top (MessageID) level, 1 = MessageName level --- , Word8 -- MessageID --- } --- all MessageName-level messages use MESSAGE_GROUPCHAT as their primary Id -data NegotiationID -- payload -- - = DefineTopLevel -- Word8(NegotiationID)Word64(RefInfo):Word64(msg-type),Word16-position,Word64-type,Word24-position ... - -- ^ Inform remote of your top-level map - | DefineMap -- Word8(NegotiationID)Word64(RefInfo):Word32(map-num),Word16-position,Word64-type,Word24-position,Word64(msg-type), ... - -- ^ Inform remote of available user-selectable second-level map - | AnnounceSelectedMap -- Word8(NegotiationID)Word64(RefInfo):Word32(map-num) - -- ^ Inform remote which second-level map he currently has selected - | RequestMap -- Word8(NegotiationID)Word64(RefInfo):Word16-position,Word64-type,Word16-position,Word64(msg-type) ... - -- ^ Ask remote for a selectable map supporting the message types at specific locations - | SelectMap -- Word8(NegotiationID)Word64(RefInfo):Word32(map-num) - -- ^ Tell remote which secondary map to use while interpretting your messages - | DiscardMap -- Word8(NegotiationID)Word64(RefInfo):Word32(map-num) - -- ^ Tell remote you aren't going to use the specified secondary map - | DenyRequest -- Word8(NegotiationID)Word64(RefInfo) - -- ^ Inform remote that you opted not to comply with his request (or selection), or there was some error - deriving (Show,Eq,Ord,Enum,Bounded) - -instance Serialize NegotiationID where - get = toEnum . fromIntegral <$> getWord8 - put x = putWord8 (fromIntegral . fromEnum $ x) - -data NegotiationMsg - = NegMsg { negID :: NegotiationID - , negNum :: Word32 - , negRef :: Word32 - , negMapNum :: Maybe Word32 - , negRange :: [((Word8,Word8),Word64)] - } deriving (Eq,Show) - -instance Sized NegotiationMsg where - size = VarSize $ \case - x | negID x == DenyRequest -> 9 - x | negID x `Prelude.elem` [SelectMap,DiscardMap,AnnounceSelectedMap] - -> 10 - x | negID x `Prelude.elem` [DefineTopLevel,RequestMap] - , xs <- negRange x -> 9 + 10 * (Prelude.length xs) - - x | negID x == DefineMap - , xs <- negRange x -> 13 + 10 * (Prelude.length xs) - -instance Serialize NegotiationMsg where - get = do - i <- get :: Get NegotiationID - num <- getWord32le :: Get Word32 - ref <- getWord32le :: Get Word32 - let getRangeReversed = flip fix [] $ \loop xs -> do - emp <- isEmpty - if emp then return xs - else do - level <- get :: Get Word8 - id <- get :: Get Word8 - typ <- getWord64le :: Get Word64 - loop (((level,id),typ):xs) - let getRange = Prelude.reverse <$> getRangeReversed - (mapNum,range) - <- case i of - x | x `Prelude.elem` [SelectMap,DiscardMap,AnnounceSelectedMap] - -> do - mapNum <- getWord32le :: Get Word32 - return (Just mapNum,[]) - x | x `Prelude.elem` [DefineTopLevel,RequestMap] - -> do - xs <- getRange - return (Nothing,xs) - DefineMap -> do - mapNum <- getWord32le :: Get Word32 - xs <- getRange - return (Just mapNum,xs) - - _ -> return (Nothing,[]) - return $ NegMsg i num ref mapNum range - - put msg = do - putWord8 (fromIntegral . fromEnum $ negID msg) - putWord32le (negNum msg) - putWord32le (negRef msg) - maybe (return ()) putWord32le (negMapNum msg) - forM_ (negRange msg) $ \((lvl,id),typ) -> do - putWord8 lvl - putWord8 id - putWord64le typ - -- cgit v1.2.3