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