From e3f7c822a3e6f57260881fa3245ad2b89087ecce Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 21 Dec 2013 02:18:16 +0400 Subject: Add DHT messages --- src/Network/BitTorrent/Core/Node.hs | 9 +- src/Network/BitTorrent/DHT/Message.hs | 240 ++++++++++++++++++++++++++++++++++ 2 files changed, 248 insertions(+), 1 deletion(-) create mode 100644 src/Network/BitTorrent/DHT/Message.hs (limited to 'src/Network/BitTorrent') diff --git a/src/Network/BitTorrent/Core/Node.hs b/src/Network/BitTorrent/Core/Node.hs index a1a87135..0cb95dd2 100644 --- a/src/Network/BitTorrent/Core/Node.hs +++ b/src/Network/BitTorrent/Core/Node.hs @@ -1,6 +1,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} module Network.BitTorrent.Core.Node ( -- * Node ID NodeId @@ -20,7 +21,9 @@ import Data.Aeson.TH import Data.Bits import Data.ByteString as BS import Data.BEncode as BE +import Data.Default import Data.Ord +import Data.Typeable import Data.Serialize as S import Data.Word import Network @@ -37,11 +40,15 @@ import Network.BitTorrent.Core.PeerAddr () -- | Normally, /this/ node id should we saved between invocations of -- the client software. newtype NodeId = NodeId ByteString - deriving (Show, Eq, Ord, BEncode, FromJSON, ToJSON) + deriving (Show, Eq, Ord, BEncode, FromJSON, ToJSON, Typeable) nodeIdSize :: Int nodeIdSize = 20 +-- | Meaningless node id, for testing purposes only. +instance Default NodeId where + def = NodeId (BS.replicate nodeIdSize 0) + instance Serialize NodeId where get = NodeId <$> getByteString nodeIdSize {-# INLINE get #-} diff --git a/src/Network/BitTorrent/DHT/Message.hs b/src/Network/BitTorrent/DHT/Message.hs new file mode 100644 index 00000000..a2a6484a --- /dev/null +++ b/src/Network/BitTorrent/DHT/Message.hs @@ -0,0 +1,240 @@ +-- | For more info see: +-- +-- +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +module Network.BitTorrent.DHT.Message + ( -- * Envelopes + Query (..) + , Response (..) + + -- * Queries + -- ** ping + , Ping (..) + + -- ** find_node + , FindNode (..) + , NodeFound (..) + + -- ** get_peers + , GetPeers (..) + , GotPeers (..) + + -- ** announce_peer + , Announce (..) + , Announced (..) + ) where + +import Control.Applicative +import Data.BEncode as BE +import Data.BEncode.BDict +import Data.ByteString as BS +import Data.Monoid +import Data.Serialize as S +import Data.Typeable +import Network +import Network.KRPC + +import Data.Torrent.InfoHash +import Network.BitTorrent.Core +import Network.KRPC () + +{----------------------------------------------------------------------- +-- envelopes +-----------------------------------------------------------------------} + +type Token = ByteString + +node_id_key :: BKey +node_id_key = "id" + +-- | All queries have an "id" key and value containing the node ID of +-- the querying node. +data Query a = Query + { thisNodeId :: NodeId + , queryParams :: a + } + +instance BEncode a => BEncode (Query a) where + toBEncode Query {..} = toDict $ + node_id_key .=! thisNodeId .: endDict + <> + dict (toBEncode queryParams) + where + dict (BDict d) = d + dict _ = error "impossible: instance BEncode (Query a)" + + fromBEncode v = do + Query <$> fromDict (field (req node_id_key)) v + <*> fromBEncode v + +-- | All responses have an "id" key and value containing the node ID +-- of the responding node. +data Response a = Response + { remoteNodeId :: NodeId + , responseVals :: a + } + +instance BEncode a => BEncode (Response a) where + toBEncode = toBEncode . toQuery + where + toQuery (Response nid a) = Query nid a + + fromBEncode b = fromQuery <$> fromBEncode b + where + fromQuery (Query nid a) = Response nid a + + +{----------------------------------------------------------------------- +-- ping method +-----------------------------------------------------------------------} + +-- | The most basic query is a ping. +data Ping = Ping + deriving Typeable + +instance BEncode Ping where + toBEncode Ping = toDict endDict + fromBEncode _ = pure Ping + +-- | \"q\" = \"ping\" +instance KRPC (Query Ping) [Ping] where + method = "ping" + +{----------------------------------------------------------------------- +-- find_node method +-----------------------------------------------------------------------} + +-- | Find node is used to find the contact information for a node +-- given its ID. +newtype FindNode = FindNode NodeId + deriving Typeable + +target_key :: BKey +target_key = "target" + +instance BEncode FindNode where + toBEncode (FindNode nid) = toDict $ target_key .=! nid .: endDict + fromBEncode = fromDict $ FindNode <$>! target_key + +-- | When a node receives a find_node query, it should respond with a +-- the compact node info for the target node or the K (8) closest good +-- nodes in its own routing table. +-- +newtype NodeFound ip = NodeFound [NodeInfo ip] + deriving Typeable + +nodes_key :: BKey +nodes_key = "nodes" + +binary :: Serialize a => BE.Get BS.ByteString -> BE.Get a +binary m = m >>= either fail return . S.decode + +instance (Typeable ip, Serialize ip) => BEncode (NodeFound ip) where + toBEncode (NodeFound ns) = toDict $ + nodes_key .=! S.encode ns + .: endDict + + fromBEncode = fromDict $ NodeFound <$> binary (field (req nodes_key)) + +-- | \"q\" == \"find_node\" +instance (Serialize ip, Typeable ip) + => KRPC (Query FindNode) (Response (NodeFound ip)) where + method = "find_node" + +{----------------------------------------------------------------------- +-- get_peers method +-----------------------------------------------------------------------} + +-- | Get peers associated with a torrent infohash. +newtype GetPeers = GetPeers InfoHash + deriving Typeable + +info_hash_key :: BKey +info_hash_key = "info_hash" + +instance BEncode GetPeers where + toBEncode (GetPeers ih) = toDict $ info_hash_key .=! ih .: endDict + fromBEncode = fromDict $ GetPeers <$>! info_hash_key + +data GotPeers ip = GotPeers + { -- | If the queried node has no peers for the infohash, returned + -- the K nodes in the queried nodes routing table closest to the + -- infohash supplied in the query. + peers :: Either [NodeAddr ip] [PeerAddr ip] + + -- | The token value is a required argument for a future + -- announce_peer query. + , grantedToken :: Token + } deriving Typeable + +peers_key :: BKey +peers_key = "peers" + +token_key :: BKey +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 + + fromBEncode = fromDict $ GotPeers <$> getPeerList <*>! token_key + where + getPeerList = Right <$> binary (field (req peers_key)) + <|> Left <$> binary (field (req nodes_key)) + +instance (Typeable ip, Serialize ip) => + KRPC (Query GetPeers) (Response (GotPeers ip)) where + method = "get_peers" + +{----------------------------------------------------------------------- +-- announce method +-----------------------------------------------------------------------} + +-- | Announce that the peer, controlling the querying node, is +-- downloading a torrent on a port. +data Announce = Announce + { -- | infohash of the torrent; + topic :: InfoHash + + -- | the port /this/ peer is listenning; + , port :: PortNumber + + -- | received in response to a previous get_peers query. + , sessionToken :: Token + } deriving Typeable + +port_key :: BKey +port_key = "port" + +instance BEncode Announce where + toBEncode Announce {..} = toDict $ + info_hash_key .=! topic + .: port_key .=! port + .: token_key .=! sessionToken + .: endDict + fromBEncode = fromDict $ do + Announce <$>! info_hash_key + <*>! port_key + <*>! token_key + +-- | The queried node must verify that the token was previously sent +-- to the same IP address as the querying node. Then the queried node +-- should store the IP address of the querying node and the supplied +-- port number under the infohash in its store of peer contact +-- information. +data Announced = Announced + +instance BEncode Announced where + toBEncode _ = toBEncode Ping + fromBEncode _ = pure Announced + +instance KRPC (Query Announce) (Response Announced) where + method = "announce_peer" \ No newline at end of file -- cgit v1.2.3 From 18347913bc66b27889c9d81d41cfe7d9a1d0d90d Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Wed, 25 Dec 2013 05:32:38 +0400 Subject: Fix GotPeers(peers) key --- bittorrent.cabal | 1 - src/Network/BitTorrent/Core/PeerAddr.hs | 2 +- src/Network/BitTorrent/DHT/Message.hs | 6 +++--- 3 files changed, 4 insertions(+), 5 deletions(-) (limited to 'src/Network/BitTorrent') diff --git a/bittorrent.cabal b/bittorrent.cabal index c98c13c7..71254829 100644 --- a/bittorrent.cabal +++ b/bittorrent.cabal @@ -61,7 +61,6 @@ library Network.BitTorrent.DHT.Message -- Network.BitTorrent.DHT.Protocol Network.BitTorrent.DHT.Routing --- Network.BitTorrent.DHT.Session -- Network.BitTorrent.Exchange Network.BitTorrent.Exchange.Assembler Network.BitTorrent.Exchange.Block diff --git a/src/Network/BitTorrent/Core/PeerAddr.hs b/src/Network/BitTorrent/Core/PeerAddr.hs index bc4a1078..86b88491 100644 --- a/src/Network/BitTorrent/Core/PeerAddr.hs +++ b/src/Network/BitTorrent/Core/PeerAddr.hs @@ -254,7 +254,7 @@ peerSockAddr PeerAddr {..} = -- | Storage used to keep track a set of known peers in client, -- tracker or DHT sessions. -newtype PeerStore a = PeerStore (HashMap InfoHash [PeerAddr a]) +newtype PeerStore ip = PeerStore (HashMap InfoHash [PeerAddr ip]) -- | Empty store. instance Default (PeerStore a) where diff --git a/src/Network/BitTorrent/DHT/Message.hs b/src/Network/BitTorrent/DHT/Message.hs index a2a6484a..85abf019 100644 --- a/src/Network/BitTorrent/DHT/Message.hs +++ b/src/Network/BitTorrent/DHT/Message.hs @@ -163,7 +163,7 @@ data GotPeers ip = GotPeers { -- | If the queried node has no peers for the infohash, returned -- the K nodes in the queried nodes routing table closest to the -- infohash supplied in the query. - peers :: Either [NodeAddr ip] [PeerAddr ip] + peers :: Either [NodeInfo ip] [PeerAddr ip] -- | The token value is a required argument for a future -- announce_peer query. @@ -171,7 +171,7 @@ data GotPeers ip = GotPeers } deriving Typeable peers_key :: BKey -peers_key = "peers" +peers_key = "values" token_key :: BKey token_key = "token" @@ -204,7 +204,7 @@ data Announce = Announce { -- | infohash of the torrent; topic :: InfoHash - -- | the port /this/ peer is listenning; + -- | the port /this/ peer is listening; , port :: PortNumber -- | received in response to a previous get_peers query. -- cgit v1.2.3 From 96098e860d20e18637764156b3a067371bd49110 Mon Sep 17 00:00:00 2001 From: Daniel Gröber Date: Sun, 22 Dec 2013 19:33:22 +0000 Subject: Add yourip field to ExtendedHandshake --- src/Network/BitTorrent/Exchange/Message.hs | 25 ++++++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) (limited to 'src/Network/BitTorrent') diff --git a/src/Network/BitTorrent/Exchange/Message.hs b/src/Network/BitTorrent/Exchange/Message.hs index d0b6c19d..b7567e60 100644 --- a/src/Network/BitTorrent/Exchange/Message.hs +++ b/src/Network/BitTorrent/Exchange/Message.hs @@ -108,6 +108,7 @@ import Data.String import Data.Text as T import Data.Typeable import Data.Word +import Data.IP import Network import Network.Socket hiding (KeepAlive) import Text.PrettyPrint as PP hiding ((<>)) @@ -661,8 +662,8 @@ data ExtendedHandshake = ExtendedHandshake -- | Client name and version. , ehsVersion :: Maybe Text --- -- | --- , yourip :: Maybe (Either HostAddress HostAddress6) + -- | IP of the remote end + , ehsYourIp :: Maybe IP } deriving (Show, Eq, Typeable) extHandshakeId :: ExtendedMessageId @@ -674,7 +675,7 @@ defaultQueueLength = 1 -- | All fields are empty. instance Default ExtendedHandshake where - def = ExtendedHandshake def def def def def def def + def = ExtendedHandshake def def def def def def def def instance BEncode ExtendedHandshake where toBEncode ExtendedHandshake {..} = toDict $ @@ -685,8 +686,11 @@ instance BEncode ExtendedHandshake where .: "p" .=? ehsPort .: "reqq" .=? ehsQueueLength .: "v" .=? ehsVersion --- .: "yourip" .=? yourip + .: "yourip" .=? (runPut <$> either put put <$> toEither <$> ehsYourIp) .: endDict + where + toEither (IPv4 v4) = Left v4 + toEither (IPv6 v6) = Right v6 fromBEncode = fromDict $ ExtendedHandshake <$>? "ipv4" @@ -696,7 +700,17 @@ instance BEncode ExtendedHandshake where <*>? "p" <*>? "reqq" <*>? "v" --- <*>? "yourip" + <*> (opt "yourip" >>= getYourIp) + +getYourIp :: Maybe BValue -> BE.Get (Maybe IP) +getYourIp f = + return $ do + BString ip <- f + either (const Nothing) Just $ + case BS.length ip of + 4 -> IPv4 <$> S.decode ip + 16 -> IPv6 <$> S.decode ip + _ -> fail "" instance Pretty ExtendedHandshake where pretty = PP.text . show @@ -722,6 +736,7 @@ nullExtendedHandshake caps = ExtendedHandshake , ehsPort = Nothing , ehsQueueLength = Just defaultQueueLength , ehsVersion = Just $ T.pack $ render $ pretty libFingerprint + , ehsYourIp = Nothing } {----------------------------------------------------------------------- -- cgit v1.2.3 From af5bc8e39f3603ba8ce362f23b0f40b9a10a4ba0 Mon Sep 17 00:00:00 2001 From: Daniel Gröber Date: Sun, 22 Dec 2013 22:04:41 +0000 Subject: Add Monoid instance for ExtendedHandshake --- src/Network/BitTorrent/Exchange/Message.hs | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) (limited to 'src/Network/BitTorrent') diff --git a/src/Network/BitTorrent/Exchange/Message.hs b/src/Network/BitTorrent/Exchange/Message.hs index b7567e60..8d0c62f4 100644 --- a/src/Network/BitTorrent/Exchange/Message.hs +++ b/src/Network/BitTorrent/Exchange/Message.hs @@ -677,6 +677,24 @@ defaultQueueLength = 1 instance Default ExtendedHandshake where def = ExtendedHandshake def def def def def def def def +instance Monoid ExtendedHandshake where + mempty = def { ehsCaps = mempty } + mappend old new = + ExtendedHandshake { + ehsCaps = ehsCaps old <> ehsCaps new, + ehsIPv4 = ehsIPv4 old `mergeOld` ehsIPv4 new, + ehsIPv6 = ehsIPv6 old `mergeOld` ehsIPv6 new, + ehsMetadataSize = ehsMetadataSize old `mergeNew` ehsMetadataSize new, + ehsPort = ehsPort old `mergeOld` ehsPort new, + ehsQueueLength = ehsQueueLength old `mergeNew` ehsQueueLength new, + ehsVersion = ehsVersion old `mergeOld` ehsVersion new, + ehsYourIp = ehsYourIp old `mergeOld` ehsYourIp new + } + where + mergeOld old new = old <|> new + mergeNew old new = new <|> old + + instance BEncode ExtendedHandshake where toBEncode ExtendedHandshake {..} = toDict $ "ipv4" .=? (S.encode <$> ehsIPv4) -- cgit v1.2.3 From f3bf620062d114de747e55a85137e1a8c08e78fe Mon Sep 17 00:00:00 2001 From: Daniel Gröber Date: Sun, 22 Dec 2013 22:05:17 +0000 Subject: Add connRemoteEhs field to Connection --- src/Network/BitTorrent/Exchange/Wire.hs | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) (limited to 'src/Network/BitTorrent') diff --git a/src/Network/BitTorrent/Exchange/Wire.hs b/src/Network/BitTorrent/Exchange/Wire.hs index 5f7b0ebe..109f6551 100644 --- a/src/Network/BitTorrent/Exchange/Wire.hs +++ b/src/Network/BitTorrent/Exchange/Wire.hs @@ -455,6 +455,9 @@ data Connection = Connection -- map. , connExtCaps :: !(IORef ExtendedCaps) + -- | Current extended handshake information from the remote peer + , connRemoteEhs :: !(IORef ExtendedHandshake) + -- | Various stats about messages sent and received. Stats can be -- used to protect /this/ peer against flood attacks. , connStats :: !(IORef ConnectionStats) @@ -550,6 +553,12 @@ setExtCaps = lift . writeRef connExtCaps getExtCaps :: Wire ExtendedCaps getExtCaps = lift $ readRef connExtCaps +setRemoteEhs :: ExtendedHandshake -> Wire () +setRemoteEhs = lift . writeRef connRemoteEhs + +getRemoteEhs :: Wire ExtendedHandshake +getRemoteEhs = lift $ readRef connRemoteEhs + -- | Get current stats. Note that this value will change with the next -- sent or received message. getStats :: Wire ConnectionStats @@ -612,8 +621,9 @@ extendedHandshake caps = do sendMessage $ nullExtendedHandshake caps msg <- recvMessage case msg of - Extended (EHandshake ExtendedHandshake {..}) -> do + Extended (EHandshake remoteEhs@(ExtendedHandshake {..})) -> do setExtCaps $ ehsCaps <> caps + setRemoteEhs remoteEhs _ -> protocolError HandshakeRefused rehandshake :: ExtendedCaps -> Wire () @@ -651,6 +661,7 @@ connectWire hs addr extCaps wire = else wire extCapsRef <- newIORef def + remoteEhs <- newIORef def statsRef <- newIORef ConnectionStats { outcomingFlow = FlowStats 1 $ handshakeStats hs , incomingFlow = FlowStats 1 $ handshakeStats hs' @@ -664,6 +675,7 @@ connectWire hs addr extCaps wire = , connThisPeerId = hsPeerId hs , connOptions = def , connExtCaps = extCapsRef + , connRemoteEhs = remoteEhs , connStats = statsRef } -- cgit v1.2.3 From 23eb8500987043a79715e01f07e2febab6adaabc Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Wed, 25 Dec 2013 07:37:35 +0400 Subject: Fix name shadowing warning in Monoid instance --- src/Network/BitTorrent/Exchange/Message.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) (limited to 'src/Network/BitTorrent') diff --git a/src/Network/BitTorrent/Exchange/Message.hs b/src/Network/BitTorrent/Exchange/Message.hs index 8d0c62f4..e93f8bbe 100644 --- a/src/Network/BitTorrent/Exchange/Message.hs +++ b/src/Network/BitTorrent/Exchange/Message.hs @@ -679,8 +679,7 @@ instance Default ExtendedHandshake where instance Monoid ExtendedHandshake where mempty = def { ehsCaps = mempty } - mappend old new = - ExtendedHandshake { + mappend old new = ExtendedHandshake { ehsCaps = ehsCaps old <> ehsCaps new, ehsIPv4 = ehsIPv4 old `mergeOld` ehsIPv4 new, ehsIPv6 = ehsIPv6 old `mergeOld` ehsIPv6 new, @@ -691,8 +690,8 @@ instance Monoid ExtendedHandshake where ehsYourIp = ehsYourIp old `mergeOld` ehsYourIp new } where - mergeOld old new = old <|> new - mergeNew old new = new <|> old + mergeOld mold mnew = mold <|> mnew + mergeNew mold mnew = mnew <|> mold instance BEncode ExtendedHandshake where -- cgit v1.2.3