From 8a46b3a8808a15017207bdcea067aa7857a95a11 Mon Sep 17 00:00:00 2001 From: joe Date: Sun, 30 Jul 2017 07:40:35 -0400 Subject: more tox work --- Tox.hs | 172 +++++++++++++++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 140 insertions(+), 32 deletions(-) diff --git a/Tox.hs b/Tox.hs index 4df329d3..6969e652 100644 --- a/Tox.hs +++ b/Tox.hs @@ -43,7 +43,8 @@ import Foreign.Ptr import Foreign.Storable import GHC.Generics (Generic) import Network.Address (Address, fromSockAddr, sockAddrPort, testIdBit, - toSockAddr, setPort, un4map, WantIP(..), ipFamily) + toSockAddr, setPort, un4map, WantIP(..), ipFamily, + either4or6) import Network.QueryResponse import Network.Socket import System.Endian @@ -65,6 +66,7 @@ import Control.Monad import Text.Read import Kademlia import Network.BitTorrent.DHT.Search (Search (..)) +import Text.Printf newtype NodeId = NodeId ByteString deriving (Eq,Ord,ByteArrayAccess, Bits, Hashable) @@ -109,7 +111,7 @@ instance ToJSON NodeInfo where , "port" .= (fromIntegral port :: Int) ] | otherwise - = JSON.object [ "node-id" .= show nid + = JSON.object [ "public_key" .= show nid , "ipv6" .= show ip6 , "port" .= (fromIntegral port :: Int) ] @@ -215,13 +217,47 @@ data TransactionId = TransactionId , cryptoNonce :: Nonce24 -- ^ Used during the encryption layer. } +-- https://toktok.ltd/spec#packet-kind +-- calls this "Packet Kind" newtype Method = MessageType Word8 deriving (Eq, Ord, S.Serialize) -pattern PingType = MessageType 0 -pattern PongType = MessageType 1 -pattern GetNodesType = MessageType 2 -pattern SendNodesType = MessageType 4 +pattern PingType = MessageType 0 -- 0x00 Ping Request +pattern PongType = MessageType 1 -- 0x01 Ping Response +pattern GetNodesType = MessageType 2 -- 0x02 Nodes Request +pattern SendNodesType = MessageType 4 -- 0x04 Nodes Response +-- 0x18 Cookie Request +-- 0x19 Cookie Response +-- 0x1a Crypto Handshake +-- 0x1b Crypto Data + +-- TODO: Auth fail: +pattern DHTRequestType = MessageType 32 -- 0x20 DHT Request + +-- 0x21 LAN Discovery + +-- TODO: Auth fail: +pattern OnionRequest0 = MessageType 128 -- 0x80 Onion Request 0 +pattern OnionRequest1 = MessageType 129 -- 0x81 Onion Request 1 +pattern OnionRequest2 = MessageType 130 -- 0x82 Onion Request 2 +pattern AnnounceType = MessageType 131 -- 0x83 Announce Request + +-- 0x84 Announce Response +-- 0x85 Onion Data Request +-- 0x86 Onion Data Response +-- 0x8c Onion Response 3 +-- 0x8d Onion Response 2 +-- 0x8e Onion Response 1 +-- 0xf0 Bootstrap Info + +-- TODO Fix these fails... +-- GetNodesType decipherAndAuth: auth fail +-- MessageType 128 decipherAndAuth: auth fail +-- MessageType 129 decipherAndAuth: auth fail +-- MessageType 130 decipherAndAuth: auth fail +-- MessageType 131 decipherAndAuth: auth fail +-- MessageType 32 decipherAndAuth: auth fail + instance Show Method where showsPrec d PingType = mappend "PingType" @@ -275,8 +311,13 @@ data Ciphered = Ciphered { cipheredMAC :: Poly1305.Auth getMessage :: S.Get (Message Ciphered) getMessage = do typ <- S.get - nid <- S.get - tid <- S.get + (nid,tid) <- case typ of -- Seriously... what the fuck? + DHTRequestType -> flip (,) <$> S.get <*> S.get + OnionRequest0 -> flip (,) <$> S.get <*> S.get + OnionRequest1 -> flip (,) <$> S.get <*> S.get + -- OnionRequest2 -> flip (,) <$> S.get <*> S.get + AnnounceType -> flip (,) <$> S.get <*> S.get + _ -> (,) <$> S.get <*> S.get mac <- Poly1305.Auth . BA.convert <$> S.getBytes 16 cnt <- S.remaining bs <- S.getBytes cnt @@ -288,8 +329,13 @@ getMessage = do putMessage :: Message Ciphered -> S.Put putMessage (Message {..}) = do S.put msgType - S.put msgOrigin - S.put msgNonce + case msgType of -- Seriously... what the fuck? + DHTRequestType -> S.put msgNonce >> S.put msgOrigin + OnionRequest0 -> S.put msgNonce >> S.put msgOrigin + OnionRequest1 -> S.put msgNonce >> S.put msgOrigin + -- OnionRequest2 -> S.put msgNonce >> S.put msgOrigin + AnnounceType -> S.put msgNonce >> S.put msgOrigin + _ -> S.put msgOrigin >> S.put msgNonce let Ciphered (Poly1305.Auth mac) bs = msgPayload S.putByteString (BA.convert mac) S.putByteString bs @@ -365,6 +411,8 @@ withSecret f sk recipient nonce x = f hash crypt x (hash, crypt) = computeSharedSecret sk recipient nonce +-- Encrypt-then-Mac: Encrypt the cleartext, then compute the MAC on the +-- ciphertext, and prepend it to the ciphertext encipherAndHash :: Poly1305.State -> XSalsa.State -> ByteString -> Ciphered encipherAndHash hash crypt m = Ciphered a c where @@ -379,6 +427,30 @@ decipherAndAuth hash crypt (Ciphered mac c) m = fst . XSalsa.combine crypt $ c a = Poly1305.finalize . Poly1305.update hash $ c +nibble :: Word8 -> Char +nibble b = intToDigit (fromIntegral (b .&. 0x0F)) + +xxd :: Int -> ByteString -> [String] +xxd offset bs | B.null bs = [] +xxd offset bs = printf "%03x: %s" offset ds : xxd (offset + B.length xs) bs' + where + ds = unwords $ map (\byte -> [nibble (byte `shiftR` 4), nibble byte]) + $ B.unpack xs + (xs,bs') = B.splitAt 16 bs + +showPayloadError ciphered naddr flow err = unlines (map (prefix ++) xs) + where + xs = unwords [show (msgType ciphered), err] + : xxd 0 (BA.convert mac <> ciphertext) + + Message { msgPayload = Ciphered (Poly1305.Auth mac) ciphertext } = ciphered + + prefix = show naddr <> flow + + +showParseError bs addr err = unlines $ + concat [ either show show (either4or6 addr), " --> ", err ] + : xxd 0 bs -- TODO: -- Represents the encrypted portion of a Tox packet. @@ -387,10 +459,12 @@ decipherAndAuth hash crypt (Ciphered mac c) -- Generic packet type: Message (Payload ByteString) parsePacket :: SecretKey -> SecretsCache -> ByteString -> SockAddr -> Either String (Message ByteString, NodeInfo) -parsePacket sk cache bs addr = do ciphered <- S.runGet getMessage bs - msg <- decryptMessage sk cache ciphered - ni <- nodeInfo (msgOrigin msg) addr - return (msg, ni) +parsePacket sk cache bs addr = left (showParseError bs addr) $ do + ciphered <- S.runGet getMessage bs + ni <- nodeInfo (msgOrigin ciphered) addr + left (showPayloadError ciphered ni " --> ") $ do + msg <- decryptMessage sk cache ciphered + return (msg, ni) encodePacket :: SecretKey -> SecretsCache -> Message ByteString -> NodeInfo -> (ByteString, SockAddr) encodePacket sk cache msg ni = ( S.runPut . putMessage $ encryptMessage sk cache (nodeId ni) msg @@ -416,20 +490,23 @@ newClient addr = do let pubkey = key2id $ toPublic secret cache <- newEmptyCache drg <- getSystemDRG - let tentative_info = NodeInfo + let tentative_ip4 = fromMaybe (IPv4 $ toEnum 0) (IPv4 <$> fromSockAddr addr) + tentative_ip6 = fromMaybe (IPv6 $ toEnum 0) (IPv6 <$> fromSockAddr addr) + tentative_info = NodeInfo { nodeId = pubkey - , nodeIP = fromMaybe (toEnum 0) $ fromSockAddr addr + , nodeIP = fromMaybe (toEnum 0) (fromSockAddr addr) , nodePort = fromMaybe 0 $ sockAddrPort addr } + tentative_info4 = tentative_info { nodeIP = tentative_ip4 } tentative_info6 <- - maybe tentative_info + maybe (tentative_info { nodeIP = tentative_ip6 }) (\ip6 -> tentative_info { nodeIP = IPv6 ip6 }) <$> global6 addr4 <- atomically $ newTChan addr6 <- atomically $ newTChan routing <- atomically $ do let nobkts = R.defaultBucketCount :: Int - tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info nobkts + tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info4 nobkts tbl6 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info6 nobkts let updateIPVote tblvar addrvar a = do bkts <- readTVar tblvar @@ -457,6 +534,7 @@ newClient addr = do map_var <- atomically $ newTVar (drg, mempty) return $ Left (mapT,map_var) let net = onInbound (updateRouting outgoingClient routing) + $ addVerbosity $ layerTransport (parsePacket secret cache) (encodePacket secret cache) $ udp @@ -477,6 +555,10 @@ newClient addr = do handlers PingType = handler PongType pingH handlers GetNodesType = handler SendNodesType $ getNodesH routing handlers _ = Nothing + -- TODO DHTRequest public key (onion) + -- TODO DHTRequest NAT ping + -- TODO BootstrapInfo 0xf0 + -- genNonce24 var (TransactionId nonce8 _) = atomically $ do (g,pending) <- readTVar var @@ -545,16 +627,36 @@ dropEnd8 :: ByteString -> ByteString dropEnd8 bs = B.take (B.length bs - 8) bs +-- Add detailed printouts for every packet. +addVerbosity tr = + tr { awaitMessage = do + m <- awaitMessage tr + forM_ m $ mapM_ $ \(msg,addr) -> do + hPutStrLn stderr ( (show addr) + ++ " --> " ++ show (msgType msg)) + return m + , sendMessage = \addr msg -> do + hPutStrLn stderr ( (show addr) + ++ " <-- " ++ show (msgType msg)) + sendMessage tr addr msg + } + classify :: Message ByteString -> MessageClass String Method TransactionId classify (Message { msgType = typ , msgPayload = bs , msgNonce = nonce24 }) = go $ TransactionId (last8 bs) nonce24 where go = case typ of - PingType -> IsQuery PingType - GetNodesType -> IsQuery GetNodesType - PongType -> IsResponse - SendNodesType -> IsResponse + PingType -> IsQuery typ + GetNodesType -> IsQuery typ + PongType -> IsResponse + SendNodesType -> IsResponse + DHTRequestType -> IsQuery typ + OnionRequest0 -> IsQuery typ + OnionRequest1 -> IsQuery typ + OnionRequest2 -> IsQuery typ + AnnounceType -> IsQuery typ + _ -> const $ IsUnknown ("Unknown message type: "++show typ) encodePayload typ (TransactionId (Nonce8 tid) nonce) self dest b = Message { msgType = typ @@ -631,6 +733,12 @@ pingH _ Ping = return Pong prefer4or6 :: NodeInfo -> Maybe WantIP -> WantIP prefer4or6 addr iptyp = fromMaybe (ipFamily $ nodeIP addr) iptyp +-- TODO: This should cover more cases +isLocal (IPv6 ip6) = (ip6 == toEnum 0) +isLocal (IPv4 ip4) = (ip4 == toEnum 0) + +isGlobal = not . isLocal + getNodesH :: Routing -> NodeInfo -> GetNodes -> IO SendNodes getNodesH routing addr (GetNodes nid) = do let preferred = prefer4or6 addr Nothing @@ -639,13 +747,16 @@ getNodesH routing addr (GetNodes nid) = do ni4 <- R.thisNode <$> readTVar (routing4 routing) ni6 <- R.thisNode <$> readTVar (routing6 routing) return $ case ipFamily (nodeIP addr) of - Want_IP4 -> (id, (++ [ni6])) - Want_IP6 -> ((++ [ni4]), id) - ks <- bool (return []) (go append4 $ routing4 routing) (preferred /= Want_IP6) - ks6 <- bool (return []) (go append6 $ routing6 routing) (preferred /= Want_IP4) - return $ case preferred of - Want_IP6 -> SendNodes (take 4 $ ks6 ++ ks) - Want_IP4 -> SendNodes (take 4 $ ks ++ ks6) + Want_IP4 | isGlobal (nodeIP ni6) -> (id, (++ [ni6])) + Want_IP6 | isGlobal (nodeIP ni4) -> ((++ [ni4]), id) + _ -> (id, id) + ks <- go append4 $ routing4 routing + ks6 <- go append6 $ routing6 routing + let (ns1,ns2) = case preferred of Want_IP6 -> (ks6,ks) + Want_IP4 -> (ks,ks6) + return $ SendNodes + $ if null ns2 then ns1 + else take 4 (take 3 ns1 ++ ns2) where go f var = f . R.kclosest toxSpace k nid <$> atomically (readTVar var) @@ -671,9 +782,6 @@ toxSend meth unwrap msg client nid addr = do -- sendQuery will return (Just (Left _)) on a parse error. We're going to -- blow it away with the join-either sequence. -- TODO: Do something with parse errors. - -- "Failed reading: Malformed ping.\nEmpty call stack\n" - -- "Failed reading: unsupported address family\nEmpty call stack\n" - either print (const $ return ()) $ fromMaybe (Left "Nothing") reply return $ join $ either (const Nothing) Just <$> reply where serializer = MethodSerializer -- cgit v1.2.3