From e06b3dbd76a0a76c872ca27b4ea33b4465d14da3 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Fri, 27 Dec 2013 05:36:45 +0400 Subject: Fix get_peers response encoding --- src/Data/Torrent/InfoHash.hs | 1 + src/Network/BitTorrent/DHT/Message.hs | 38 +++++++++------ tests/Network/BitTorrent/CoreSpec.hs | 3 ++ tests/Network/BitTorrent/DHT/MessageSpec.hs | 75 ++++++++++++++++++++++++----- 4 files changed, 91 insertions(+), 26 deletions(-) diff --git a/src/Data/Torrent/InfoHash.hs b/src/Data/Torrent/InfoHash.hs index 4d49fcb7..9eec631c 100644 --- a/src/Data/Torrent/InfoHash.hs +++ b/src/Data/Torrent/InfoHash.hs @@ -120,6 +120,7 @@ instance Convertible BS.ByteString InfoHash where -- | Parse infohash from base16\/base32\/base64 encoded string. instance Convertible Text InfoHash where safeConvert t + | 20 == hashLen = pure (InfoHash hashStr) | 26 <= hashLen && hashLen <= 28 = case Base64.decode hashStr of Left msg -> convError ("invalid base64 encoding " ++ msg) t diff --git a/src/Network/BitTorrent/DHT/Message.hs b/src/Network/BitTorrent/DHT/Message.hs index 0733a85d..15d1099c 100644 --- a/src/Network/BitTorrent/DHT/Message.hs +++ b/src/Network/BitTorrent/DHT/Message.hs @@ -31,6 +31,7 @@ import Control.Applicative import Data.BEncode as BE import Data.BEncode.BDict import Data.ByteString as BS +import Data.List as L import Data.Monoid import Data.Serialize as S import Data.Typeable @@ -138,7 +139,7 @@ binary k = field (req k) >>= either (fail . format) return . instance (Typeable ip, Serialize ip) => BEncode (NodeFound ip) where toBEncode (NodeFound ns) = toDict $ - nodes_key .=! S.encode ns + nodes_key .=! runPut (mapM_ put ns) .: endDict fromBEncode = fromDict $ NodeFound <$> binary nodes_key @@ -154,7 +155,7 @@ instance (Serialize ip, Typeable ip) -- | Get peers associated with a torrent infohash. newtype GetPeers = GetPeers InfoHash - deriving Typeable + deriving (Show, Eq, Typeable) info_hash_key :: BKey info_hash_key = "info_hash" @@ -172,7 +173,7 @@ data GotPeers ip = GotPeers -- | The token value is a required argument for a future -- announce_peer query. , grantedToken :: Token - } deriving Typeable + } deriving (Show, Eq, Typeable) peers_key :: BKey peers_key = "values" @@ -182,17 +183,25 @@ token_key = "token" instance (Typeable ip, Serialize ip) => BEncode (GotPeers ip) where toBEncode GotPeers {..} = toDict $ - putPeerList peers - .: token_key .=! grantedToken - .: endDict - where - putPeerList (Right ps) = peers_key .=! S.encode ps - putPeerList (Left ns) = nodes_key .=! S.encode ns + case peers of + Left ns -> + nodes_key .=! runPut (mapM_ put ns) + .: token_key .=! grantedToken + .: endDict + Right ps -> + token_key .=! grantedToken + .: peers_key .=! L.map S.encode ps + .: endDict - fromBEncode = fromDict $ GotPeers <$> getPeerList <*>! token_key - where - getPeerList = Right <$> binary peers_key - <|> Left <$> binary nodes_key + fromBEncode = fromDict $ do + mns <- optional (binary nodes_key) -- "nodes" + tok <- field (req token_key) -- "token" + mps <- optional (field (req peers_key) >>= decodePeers) -- "values" + case (Right <$> mps) <|> (Left <$> mns) of + Nothing -> fail "get_peers: neihter peers nor nodes key is valid" + Just xs -> pure $ GotPeers xs tok + where + decodePeers = either fail pure . mapM S.decode instance (Typeable ip, Serialize ip) => KRPC (Query GetPeers) (Response (GotPeers ip)) where @@ -213,7 +222,7 @@ data Announce = Announce -- | received in response to a previous get_peers query. , sessionToken :: Token - } deriving Typeable + } deriving (Show, Eq, Typeable) port_key :: BKey port_key = "port" @@ -235,6 +244,7 @@ instance BEncode Announce where -- port number under the infohash in its store of peer contact -- information. data Announced = Announced + deriving (Show, Eq, Typeable) instance BEncode Announced where toBEncode _ = toBEncode Ping diff --git a/tests/Network/BitTorrent/CoreSpec.hs b/tests/Network/BitTorrent/CoreSpec.hs index 917ed5f5..9f9eb0eb 100644 --- a/tests/Network/BitTorrent/CoreSpec.hs +++ b/tests/Network/BitTorrent/CoreSpec.hs @@ -1,6 +1,9 @@ -- | Re-export modules. module Network.BitTorrent.CoreSpec (spec) where +import Network.BitTorrent.Core.FingerprintSpec as CoreSpec () +import Network.BitTorrent.Core.NodeSpec as CoreSpec () import Network.BitTorrent.Core.PeerIdSpec as CoreSpec () +import Network.BitTorrent.Core.PeerAddrSpec as CoreSpec () import Test.Hspec (Spec) diff --git a/tests/Network/BitTorrent/DHT/MessageSpec.hs b/tests/Network/BitTorrent/DHT/MessageSpec.hs index 9f4c58b0..52bda932 100644 --- a/tests/Network/BitTorrent/DHT/MessageSpec.hs +++ b/tests/Network/BitTorrent/DHT/MessageSpec.hs @@ -1,14 +1,19 @@ {-# LANGUAGE RecordWildCards #-} module Network.BitTorrent.DHT.MessageSpec (spec) where import Control.Monad.Reader -import Test.Hspec import Data.BEncode as BE +import Data.ByteString.Lazy as BL import Data.Default import Data.List as L import Network.BitTorrent.Core import Network.BitTorrent.DHT.Message import Network.KRPC import Network.Socket (PortNumber) +import Test.Hspec +import Test.QuickCheck + +import Network.BitTorrent.CoreSpec () +import Data.Torrent.InfoHashSpec () remoteAddr :: SockAddr @@ -29,6 +34,9 @@ rpc action = do isProtocolError :: KError -> Bool isProtocolError KError {..} = errorCode == ProtocolError +prop_bencode :: Eq a => Show a => BEncode a => a -> Expectation +prop_bencode x = BE.decode (BL.toStrict (BE.encode x)) `shouldBe` Right x + spec :: Spec spec = do context ("you need running DHT node at " ++ show remoteAddr) $ do @@ -46,8 +54,9 @@ spec = do BE.encode (Response "mnopqrstuvwxyz123456" Ping) `shouldBe` "d2:id20:mnopqrstuvwxyz123456e" - it "properly bencoded (iso)" $ do - pending + it "properly bencoded (iso)" $ property $ \ nid -> do + prop_bencode (Query nid Ping) + prop_bencode (Response nid Ping) it "does compatible with existing DHT" $ do nid <- genNodeId @@ -74,8 +83,9 @@ spec = do \e" `shouldBe` Right (Response nid (NodeFound [NodeInfo nid' naddr])) - it "properly bencoded (iso)" $ do - pending + it "properly bencoded (iso)" $ property $ \ nid x xs -> do + prop_bencode (Query nid (FindNode x)) + prop_bencode (Response nid (NodeFound (xs :: [NodeInfo IPv4] ))) it "does compatible with existing DHT" $ do nid <- genNodeId @@ -85,10 +95,38 @@ spec = do describe "get_peers" $ do it "properly bencoded" $ do - pending - - it "properly bencoded (iso)" $ do - pending + BE.decode "d2:id20:abcdefghij0123456789\ + \9:info_hash20:mnopqrstuvwxyz123456\ + \e" + `shouldBe` Right (Query "abcdefghij0123456789" + (GetPeers "mnopqrstuvwxyz123456")) + + BE.decode "d2:id20:abcdefghij0123456789\ + \5:token8:aoeusnth\ + \6:valuesl6:\127\0\0\1\1\2\&6:\192\168\1\100\1\2e\ + \e" + `shouldBe` Right (Response "abcdefghij0123456789" + (GotPeers (Right [ "127.0.0.1:258" :: PeerAddr IPv4 + , "192.168.1.100:258" + ]) "aoeusnth")) + + BE.decode "d2:id20:abcdefghij0123456789\ + \5:nodes26:mnopqrstuvwxyz123456\127\0\0\1\1\2\ + \5:token8:aoeusnth\ + \e" + `shouldBe` Right (Response "abcdefghij0123456789" + (GotPeers + { peers = Left [NodeInfo "mnopqrstuvwxyz123456" "127.0.0.1:258" + :: NodeInfo IPv4] + , grantedToken = "aoeusnth" + })) + + it "properly bencoded (iso)" $ property $ \ nid topic exs token -> do + prop_bencode (Query nid (GetPeers topic)) + let _ = exs :: Either [NodeInfo IPv4] [PeerAddr IPv4] + let nullPeerId paddr = paddr {peerId = Nothing} + let nullPeerIds = either Left (Right . L.map nullPeerId) + prop_bencode (Response nid (GotPeers (nullPeerIds exs) token)) it "does compatible with existing DHT" $ do nid <- genNodeId @@ -99,10 +137,23 @@ spec = do describe "announce" $ do it "properly bencoded" $ do - pending + BE.decode "d2:id20:abcdefghij0123456789\ + \9:info_hash20:mnopqrstuvwxyz123456\ + \4:porti6881e\ + \5:token8:aoeusnth\ + \e" `shouldBe` Right + (Query "abcdefghij0123456789" + (Announce "mnopqrstuvwxyz123456" 6881 "aoeusnth")) + + + BE.decode "d2:id20:mnopqrstuvwxyz123456e" + `shouldBe` Right + (Response "mnopqrstuvwxyz123456" Announced) + + it "properly bencoded (iso)" $ property $ \ nid topic port token -> do + prop_bencode (Query nid (Announce topic port token)) + prop_bencode (Response nid (Announced)) - it "properly bencoded (iso)" $ do - pending it "does compatible with existing DHT" $ do nid <- genNodeId -- cgit v1.2.3