From 602ce9260950a0eb91cefe4603af5de2443e2fea Mon Sep 17 00:00:00 2001 From: joe Date: Mon, 12 Jun 2017 21:55:31 -0400 Subject: Rename Network.BitTorrent.DHT.Message -> Network.DHT.Mainline --- src/Network/BitTorrent/DHT/Message.hs | 509 ---------------------------------- src/Network/BitTorrent/DHT/Query.hs | 2 +- src/Network/BitTorrent/DHT/Session.hs | 2 +- src/Network/BitTorrent/DHT/Token.hs | 2 +- src/Network/DHT/Mainline.hs | 509 ++++++++++++++++++++++++++++++++++ 5 files changed, 512 insertions(+), 512 deletions(-) delete mode 100644 src/Network/BitTorrent/DHT/Message.hs create mode 100644 src/Network/DHT/Mainline.hs (limited to 'src/Network') diff --git a/src/Network/BitTorrent/DHT/Message.hs b/src/Network/BitTorrent/DHT/Message.hs deleted file mode 100644 index e21e0e70..00000000 --- a/src/Network/BitTorrent/DHT/Message.hs +++ /dev/null @@ -1,509 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- This module provides message datatypes which is used for /Node to --- Node/ communication. Bittorrent DHT is based on Kademlia --- specification, but have a slightly different set of messages --- which have been adopted for /peer/ discovery mechanism. Messages --- are sent over "Network.KRPC" protocol, but normally you should --- use "Network.BitTorrent.DHT.Session" to send and receive --- messages. --- --- DHT queries are not /recursive/, they are /iterative/. This means --- that /querying/ node . While original specification (namely BEP5) --- do not impose any restrictions for /quered/ node behaviour, a --- good DHT implementation should follow some rules to guarantee --- that unlimit recursion will never happen. The following set of --- restrictions: --- --- * 'Ping' query must not trigger any message. --- --- * 'FindNode' query /may/ trigger 'Ping' query to check if a --- list of nodes to return is /good/. See --- 'Network.DHT.Routing.Routing' for further explanation. --- --- * 'GetPeers' query may trigger 'Ping' query for the same reason. --- --- * 'Announce' query must trigger 'Ping' query for the same reason. --- --- It is easy to see that the most long RPC chain is: --- --- @ --- | | | --- Node_A | | --- | FindNode or GetPeers or Announce | | --- | ------------------------------------> Node_B | --- | | Ping | --- | | -----------> | --- | | Node_C --- | | Pong | --- | NodeFound or GotPeers or Announced | <----------- | --- | <------------------------------------- Node_B | --- Node_A | | --- | | | --- @ --- --- where in some cases 'Node_C' is 'Node_A'. --- --- For more info see: --- --- --- For Kamelia messages see original Kademlia paper: --- --- -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -module Network.BitTorrent.DHT.Message - ( -- * Envelopes - Query (..) - , Response (..) - - -- * Queries - -- ** ping - , Ping (..) - - -- ** find_node - , FindNode (..) - , NodeFound (..) - , bep42s - -- , bep42 - - -#ifdef VERSION_bencoding - -- ** get_peers - , PeerList - , GetPeers (..) - , GotPeers (..) - - -- ** announce_peer - , Announce (..) - , Announced (..) -#endif - ) where - -import Control.Applicative -import Data.Bool -#ifdef VERSION_bencoding -import Data.BEncode as BE -import Data.BEncode.BDict as BDict hiding (map) -#else -import qualified Network.DatagramServer.Tox as Tox -import Network.DatagramServer.Tox (NodeId) -import Data.Word -import Control.Monad -#endif -import Network.KRPC.Method -import Network.Address hiding (NodeId) -import Data.Bits -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.Digest.CRC32C -import Data.List as L -import Data.Monoid -import Data.Serialize as S -import Data.Typeable -import Data.Word -import Network -import Network.DatagramServer -import Network.DatagramServer.Mainline -import Data.Maybe - -import Data.Torrent (InfoHash) -import Network.BitTorrent.DHT.Token -#ifdef VERSION_bencoding -import Network.DatagramServer () -#endif -import Network.DatagramServer.Types hiding (Query,Response) - -{----------------------------------------------------------------------- --- envelopes ------------------------------------------------------------------------} - -#ifndef VERSION_bencoding -type BKey = ByteString -#endif - -node_id_key :: BKey -node_id_key = "id" - -read_only_key :: BKey -read_only_key = "ro" - - -#ifdef VERSION_bencoding --- | All queries have an \"id\" key and value containing the node ID --- of the querying node. -data Query a = Query - { queringNodeId :: NodeId KMessageOf -- ^ node id of /quering/ node; - , queryIsReadOnly :: Bool -- ^ node is read-only as per BEP 43 - , queryParams :: a -- ^ query parameters. - } deriving (Show, Eq, Typeable) - -instance BEncode a => BEncode (Query a) where - toBEncode Query {..} = toDict $ - BDict.union ( node_id_key .=! queringNodeId - .: read_only_key .=? bool Nothing (Just (1 :: Integer)) queryIsReadOnly - .: 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 - <*> fromDict (fromMaybe False <$>? read_only_key) v - <*> fromBEncode v -#else -data Query a = Query a -#endif - -#ifdef VERSION_bencoding --- | All responses have an \"id\" key and value containing the node ID --- of the responding node. -data Response a = Response - { queredNodeId :: NodeId KMessageOf -- ^ node id of /quered/ node; - , responseVals :: a -- ^ query result. - } deriving (Show, Eq, Typeable) - -instance BEncode a => BEncode (Response a) where - toBEncode = toBEncode . toQuery - where - toQuery (Response nid a) = Query nid False a - - fromBEncode b = fromQuery <$> fromBEncode b - where - fromQuery (Query nid _ a) = Response nid a -#else -data Response a = Response a -#endif - -{----------------------------------------------------------------------- --- ping method ------------------------------------------------------------------------} - --- | The most basic query is a ping. Ping query is used to check if a --- quered node is still alive. -#ifdef VERSION_bencoding -data Ping = Ping -#else -data Ping = Ping Tox.Nonce8 -#endif - deriving (Show, Eq, Typeable) - -#ifdef VERSION_bencoding -instance BEncode Ping where - toBEncode Ping = toDict endDict - fromBEncode _ = pure Ping -#else -instance Serialize (Query Ping) where - get = do - b <- get - when ( (b::Word8) /= 0) $ fail "Bad ping request" - nonce <- get - return $ Query (Ping nonce) - put (Query (Ping nonce)) = do - put (0 :: Word8) - put nonce -instance Serialize (Response Ping) where - get = do - b <- get - when ( (b::Word8) /= 1) $ fail "Bad ping response" - nonce <- get - return $ Response (Ping nonce) - put (Response (Ping nonce)) = do - put (1 :: Word8) - put nonce -#endif - --- | \"q\" = \"ping\" -instance KRPC (Query Ping) (Response Ping) where -#ifdef VERSION_bencoding - type Envelope (Query Ping) (Response Ping) = BValue - seal = toBEncode - unseal = fromBEncode - method = "ping" -#else - method = Method Tox.Ping -- response: Tox.Pong -#endif - -{----------------------------------------------------------------------- --- find_node method ------------------------------------------------------------------------} - --- | Find node is used to find the contact information for a node --- given its ID. -#ifdef VERSION_bencoding -newtype FindNode ip = FindNode (NodeId KMessageOf) -#else -data FindNode ip = FindNode (NodeId Tox.Message) Tox.Nonce8 -- Tox: Get Nodes -#endif - deriving (Show, Eq, Typeable) - -target_key :: BKey -target_key = "target" - -#ifdef VERSION_bencoding -instance Typeable ip => BEncode (FindNode ip) where - toBEncode (FindNode nid) = toDict $ target_key .=! nid .: endDict - fromBEncode = fromDict $ FindNode <$>! target_key -#else -instance Serialize (Query (FindNode ip)) where - get = do - nid <- get - nonce <- get - return $ Query (FindNode nid nonce) - put (Query (FindNode nid nonce)) = do - put nid - put nonce -#endif - --- | When a node receives a 'FindNode' 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. --- -#ifdef VERSION_bencoding -newtype NodeFound ip = NodeFound [NodeInfo KMessageOf ip ()] -#else -data NodeFound ip = NodeFound [Tox.NodeFormat] Tox.Nonce8 -#endif --- Tox: send_nodes - deriving (Show, Eq, Typeable) - -nodes_key :: BKey -nodes_key = "nodes" - --- Convert IPv4 address. Useful for using variadic IP type. -from4 :: forall dht u s. Address s => NodeInfo dht IPv4 u -> Either String (NodeInfo dht s u) -from4 n = maybe (Left "Error converting IPv4") Right - $ traverseAddress (fromAddr :: IPv4 -> Maybe s) n - -#ifdef VERSION_bencoding -binary :: Serialize a => BKey -> BE.Get [a] -binary k = field (req k) >>= either (fail . format) return . - runGet (many get) - where - format str = "fail to deserialize " ++ show k ++ " field: " ++ str - -instance Address ip => BEncode (NodeFound ip) where - toBEncode (NodeFound ns) = toDict $ - nodes_key .=! runPut (mapM_ put ns) - .: endDict - - -- TODO: handle IPv6 by reading the "nodes6" key (see bep 32) - fromBEncode bval = NodeFound <$> (traverse from4 =<< fromDict (binary nodes_key) bval) -#else -instance Serialize (Response (NodeFound ip)) where - get = do - count <- get :: Get Word8 - nodes <- sequence $ replicate (fromIntegral count) get - nonce <- get :: Get Tox.Nonce8 - return $ Response $ NodeFound nodes nonce - - put (Response (NodeFound nodes nonce)) = do - put (fromIntegral (length nodes) :: Word8) - mapM_ put nodes - put nonce - -#endif - --- | \"q\" == \"find_node\" -instance (Address ip, Typeable ip) - => KRPC (Query (FindNode ip)) (Response (NodeFound ip)) where -#ifdef VERSION_bencoding - type Envelope (Query (FindNode ip)) (Response (NodeFound ip)) = BValue - seal = toBEncode - unseal = fromBEncode - method = "find_node" -#else - method = Method Tox.GetNodes -- response: Tox.SendNodes -#endif - -#ifdef VERSION_bencoding -{----------------------------------------------------------------------- --- get_peers method ------------------------------------------------------------------------} - --- | Get peers associated with a torrent infohash. -newtype GetPeers ip = GetPeers InfoHash - deriving (Show, Eq, Typeable) - -info_hash_key :: BKey -info_hash_key = "info_hash" - -instance Typeable ip => BEncode (GetPeers ip) where - toBEncode (GetPeers ih) = toDict $ info_hash_key .=! ih .: endDict - fromBEncode = fromDict $ GetPeers <$>! info_hash_key - -type PeerList ip = Either [NodeInfo KMessageOf ip ()] [PeerAddr ip] - -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 :: PeerList ip - - -- | The token value is a required argument for a future - -- announce_peer query. - , grantedToken :: Token - } deriving (Show, Eq, Typeable) - -peers_key :: BKey -peers_key = "values" - -token_key :: BKey -token_key = "token" - -name_key :: BKey -name_key = "name" - -instance (Typeable ip, Serialize ip) => BEncode (GotPeers ip) where - toBEncode GotPeers {..} = toDict $ - 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 $ 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 - --- | \"q" = \"get_peers\" -instance (Typeable ip, Serialize ip) => - KRPC (Query (GetPeers ip)) (Response (GotPeers ip)) where - type Envelope (Query (GetPeers ip)) (Response (GotPeers ip)) = BValue - seal = toBEncode - unseal = fromBEncode - method = "get_peers" - -{----------------------------------------------------------------------- --- announce method ------------------------------------------------------------------------} - --- | Announce that the peer, controlling the querying node, is --- downloading a torrent on a port. -data Announce = Announce - { -- | If set, the 'port' field should be ignored and the source - -- port of the UDP packet should be used as the peer's port - -- instead. This is useful for peers behind a NAT that may not - -- know their external port, and supporting uTP, they accept - -- incoming connections on the same port as the DHT port. - impliedPort :: Bool - - -- | infohash of the torrent; - , topic :: InfoHash - - -- | some clients announce the friendly name of the torrent here. - , announcedName :: Maybe ByteString - - -- | the port /this/ peer is listening; - , port :: PortNumber - - -- TODO: optional boolean "seed" key - - -- | received in response to a previous get_peers query. - , sessionToken :: Token - - } deriving (Show, Eq, Typeable) - -port_key :: BKey -port_key = "port" - -implied_port_key :: BKey -implied_port_key = "implied_port" - -instance BEncode Announce where - toBEncode Announce {..} = toDict $ - implied_port_key .=? flagField impliedPort - .: info_hash_key .=! topic - .: name_key .=? announcedName - .: port_key .=! port - .: token_key .=! sessionToken - .: endDict - where - flagField flag = if flag then Just (1 :: Int) else Nothing - - fromBEncode = fromDict $ do - Announce <$> (boolField <$> optional (field (req implied_port_key))) - <*>! info_hash_key - <*>? name_key - <*>! port_key - <*>! token_key - where - boolField = maybe False (/= (0 :: Int)) - --- | 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 - deriving (Show, Eq, Typeable) - -instance BEncode Announced where - toBEncode _ = toBEncode Ping - fromBEncode _ = pure Announced - --- | \"q" = \"announce\" -instance KRPC (Query Announce) (Response Announced) where - type Envelope (Query Announce) (Response Announced) = BValue - seal = toBEncode - unseal = fromBEncode - method = "announce_peer" - --- endif VERSION_bencoding -#endif - --- | Yields all 8 DHT neighborhoods available to you given a particular ip --- address. -bep42s :: Address a => a -> NodeId KMessageOf -> [NodeId KMessageOf] -bep42s addr (NodeId r) = mapMaybe (bep42 addr) rs - where - rs = map (NodeId . change3bits r) [0..7] - --- change3bits :: ByteString -> Word8 -> ByteString --- change3bits bs n = BS.snoc (BS.init bs) (BS.last bs .&. 0xF8 .|. n) - -change3bits :: (Num b, Bits b) => b -> b -> b -change3bits bs n = (bs .&. complement 7) .|. n - --- | Modifies a purely random 'NodeId' to one that is related to a given --- routable address in accordance with BEP 42. -bep42 :: Address a => a -> NodeId KMessageOf -> Maybe (NodeId KMessageOf) -bep42 addr (NodeId r) - | Just ip <- fmap S.encode (fromAddr addr :: Maybe IPv4) - <|> fmap S.encode (fromAddr addr :: Maybe IPv6) - = genBucketSample' retr (NodeId $ crc $ applyMask ip) (3,0x07,0) - | otherwise - = Nothing - where - ip4mask = "\x03\x0f\x3f\xff" :: ByteString - ip6mask = "\x01\x03\x07\x0f\x1f\x3f\x7f\xff" :: ByteString - nbhood_select = (fromIntegral r :: Word8) .&. 7 - retr n = pure $ BS.drop (nodeIdSize - n) $ S.encode r - crc = flip shiftL (finiteBitSize (NodeId undefined) - 32) . fromIntegral . crc32c . BS.pack - applyMask ip = case BS.zipWith (.&.) msk ip of - (b:bs) -> (b .|. shiftL nbhood_select 5) : bs - bs -> bs - where msk | BS.length ip == 4 = ip4mask - | otherwise = ip6mask - diff --git a/src/Network/BitTorrent/DHT/Query.hs b/src/Network/BitTorrent/DHT/Query.hs index edc238e6..ae072db0 100644 --- a/src/Network/BitTorrent/DHT/Query.hs +++ b/src/Network/BitTorrent/DHT/Query.hs @@ -86,7 +86,7 @@ import Network.KRPC.Method as KRPC import Network.DatagramServer.Mainline (ReflectedIP(..)) import Network.DatagramServer (QueryFailure(..)) import Data.Torrent -import Network.BitTorrent.DHT.Message +import Network.DHT.Mainline import Network.DHT.Routing as R import Network.BitTorrent.DHT.Session import Control.Concurrent.STM diff --git a/src/Network/BitTorrent/DHT/Session.hs b/src/Network/BitTorrent/DHT/Session.hs index e205add4..2d290a95 100644 --- a/src/Network/BitTorrent/DHT/Session.hs +++ b/src/Network/BitTorrent/DHT/Session.hs @@ -116,7 +116,7 @@ import Network.DatagramServer.Tox as Tox import Network.Address import Network.BitTorrent.DHT.ContactInfo (PeerStore) import qualified Network.BitTorrent.DHT.ContactInfo as P -import Network.BitTorrent.DHT.Message +import Network.DHT.Mainline import Network.DHT.Routing as R import Network.BitTorrent.DHT.Token as T diff --git a/src/Network/BitTorrent/DHT/Token.hs b/src/Network/BitTorrent/DHT/Token.hs index 75eadd1a..e3a6b1f6 100644 --- a/src/Network/BitTorrent/DHT/Token.hs +++ b/src/Network/BitTorrent/DHT/Token.hs @@ -109,7 +109,7 @@ lookup addr TokenMap {..} = makeToken addr curSecret -- | Check if token is valid. -- --- Typically used to handle 'Network.BitTorrent.DHT.Message.Announce' +-- Typically used to handle 'Network.DHT.Mainline.Announce' -- query. If token is invalid the 'Network.KRPC.ProtocolError' should -- be sent back to the malicious node. member :: Hashable a => NodeAddr a -> Token -> TokenMap -> Bool diff --git a/src/Network/DHT/Mainline.hs b/src/Network/DHT/Mainline.hs new file mode 100644 index 00000000..a5f4f606 --- /dev/null +++ b/src/Network/DHT/Mainline.hs @@ -0,0 +1,509 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- This module provides message datatypes which is used for /Node to +-- Node/ communication. Bittorrent DHT is based on Kademlia +-- specification, but have a slightly different set of messages +-- which have been adopted for /peer/ discovery mechanism. Messages +-- are sent over "Network.KRPC" protocol, but normally you should +-- use "Network.BitTorrent.DHT.Session" to send and receive +-- messages. +-- +-- DHT queries are not /recursive/, they are /iterative/. This means +-- that /querying/ node . While original specification (namely BEP5) +-- do not impose any restrictions for /quered/ node behaviour, a +-- good DHT implementation should follow some rules to guarantee +-- that unlimit recursion will never happen. The following set of +-- restrictions: +-- +-- * 'Ping' query must not trigger any message. +-- +-- * 'FindNode' query /may/ trigger 'Ping' query to check if a +-- list of nodes to return is /good/. See +-- 'Network.DHT.Routing.Routing' for further explanation. +-- +-- * 'GetPeers' query may trigger 'Ping' query for the same reason. +-- +-- * 'Announce' query must trigger 'Ping' query for the same reason. +-- +-- It is easy to see that the most long RPC chain is: +-- +-- @ +-- | | | +-- Node_A | | +-- | FindNode or GetPeers or Announce | | +-- | ------------------------------------> Node_B | +-- | | Ping | +-- | | -----------> | +-- | | Node_C +-- | | Pong | +-- | NodeFound or GotPeers or Announced | <----------- | +-- | <------------------------------------- Node_B | +-- Node_A | | +-- | | | +-- @ +-- +-- where in some cases 'Node_C' is 'Node_A'. +-- +-- For more info see: +-- +-- +-- For Kamelia messages see original Kademlia paper: +-- +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Network.DHT.Mainline + ( -- * Envelopes + Query (..) + , Response (..) + + -- * Queries + -- ** ping + , Ping (..) + + -- ** find_node + , FindNode (..) + , NodeFound (..) + , bep42s + -- , bep42 + + +#ifdef VERSION_bencoding + -- ** get_peers + , PeerList + , GetPeers (..) + , GotPeers (..) + + -- ** announce_peer + , Announce (..) + , Announced (..) +#endif + ) where + +import Control.Applicative +import Data.Bool +#ifdef VERSION_bencoding +import Data.BEncode as BE +import Data.BEncode.BDict as BDict hiding (map) +#else +import qualified Network.DatagramServer.Tox as Tox +import Network.DatagramServer.Tox (NodeId) +import Data.Word +import Control.Monad +#endif +import Network.KRPC.Method +import Network.Address hiding (NodeId) +import Data.Bits +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Digest.CRC32C +import Data.List as L +import Data.Monoid +import Data.Serialize as S +import Data.Typeable +import Data.Word +import Network +import Network.DatagramServer +import Network.DatagramServer.Mainline +import Data.Maybe + +import Data.Torrent (InfoHash) +import Network.BitTorrent.DHT.Token +#ifdef VERSION_bencoding +import Network.DatagramServer () +#endif +import Network.DatagramServer.Types hiding (Query,Response) + +{----------------------------------------------------------------------- +-- envelopes +-----------------------------------------------------------------------} + +#ifndef VERSION_bencoding +type BKey = ByteString +#endif + +node_id_key :: BKey +node_id_key = "id" + +read_only_key :: BKey +read_only_key = "ro" + + +#ifdef VERSION_bencoding +-- | All queries have an \"id\" key and value containing the node ID +-- of the querying node. +data Query a = Query + { queringNodeId :: NodeId KMessageOf -- ^ node id of /quering/ node; + , queryIsReadOnly :: Bool -- ^ node is read-only as per BEP 43 + , queryParams :: a -- ^ query parameters. + } deriving (Show, Eq, Typeable) + +instance BEncode a => BEncode (Query a) where + toBEncode Query {..} = toDict $ + BDict.union ( node_id_key .=! queringNodeId + .: read_only_key .=? bool Nothing (Just (1 :: Integer)) queryIsReadOnly + .: 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 + <*> fromDict (fromMaybe False <$>? read_only_key) v + <*> fromBEncode v +#else +data Query a = Query a +#endif + +#ifdef VERSION_bencoding +-- | All responses have an \"id\" key and value containing the node ID +-- of the responding node. +data Response a = Response + { queredNodeId :: NodeId KMessageOf -- ^ node id of /quered/ node; + , responseVals :: a -- ^ query result. + } deriving (Show, Eq, Typeable) + +instance BEncode a => BEncode (Response a) where + toBEncode = toBEncode . toQuery + where + toQuery (Response nid a) = Query nid False a + + fromBEncode b = fromQuery <$> fromBEncode b + where + fromQuery (Query nid _ a) = Response nid a +#else +data Response a = Response a +#endif + +{----------------------------------------------------------------------- +-- ping method +-----------------------------------------------------------------------} + +-- | The most basic query is a ping. Ping query is used to check if a +-- quered node is still alive. +#ifdef VERSION_bencoding +data Ping = Ping +#else +data Ping = Ping Tox.Nonce8 +#endif + deriving (Show, Eq, Typeable) + +#ifdef VERSION_bencoding +instance BEncode Ping where + toBEncode Ping = toDict endDict + fromBEncode _ = pure Ping +#else +instance Serialize (Query Ping) where + get = do + b <- get + when ( (b::Word8) /= 0) $ fail "Bad ping request" + nonce <- get + return $ Query (Ping nonce) + put (Query (Ping nonce)) = do + put (0 :: Word8) + put nonce +instance Serialize (Response Ping) where + get = do + b <- get + when ( (b::Word8) /= 1) $ fail "Bad ping response" + nonce <- get + return $ Response (Ping nonce) + put (Response (Ping nonce)) = do + put (1 :: Word8) + put nonce +#endif + +-- | \"q\" = \"ping\" +instance KRPC (Query Ping) (Response Ping) where +#ifdef VERSION_bencoding + type Envelope (Query Ping) (Response Ping) = BValue + seal = toBEncode + unseal = fromBEncode + method = "ping" +#else + method = Method Tox.Ping -- response: Tox.Pong +#endif + +{----------------------------------------------------------------------- +-- find_node method +-----------------------------------------------------------------------} + +-- | Find node is used to find the contact information for a node +-- given its ID. +#ifdef VERSION_bencoding +newtype FindNode ip = FindNode (NodeId KMessageOf) +#else +data FindNode ip = FindNode (NodeId Tox.Message) Tox.Nonce8 -- Tox: Get Nodes +#endif + deriving (Show, Eq, Typeable) + +target_key :: BKey +target_key = "target" + +#ifdef VERSION_bencoding +instance Typeable ip => BEncode (FindNode ip) where + toBEncode (FindNode nid) = toDict $ target_key .=! nid .: endDict + fromBEncode = fromDict $ FindNode <$>! target_key +#else +instance Serialize (Query (FindNode ip)) where + get = do + nid <- get + nonce <- get + return $ Query (FindNode nid nonce) + put (Query (FindNode nid nonce)) = do + put nid + put nonce +#endif + +-- | When a node receives a 'FindNode' 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. +-- +#ifdef VERSION_bencoding +newtype NodeFound ip = NodeFound [NodeInfo KMessageOf ip ()] +#else +data NodeFound ip = NodeFound [Tox.NodeFormat] Tox.Nonce8 +#endif +-- Tox: send_nodes + deriving (Show, Eq, Typeable) + +nodes_key :: BKey +nodes_key = "nodes" + +-- Convert IPv4 address. Useful for using variadic IP type. +from4 :: forall dht u s. Address s => NodeInfo dht IPv4 u -> Either String (NodeInfo dht s u) +from4 n = maybe (Left "Error converting IPv4") Right + $ traverseAddress (fromAddr :: IPv4 -> Maybe s) n + +#ifdef VERSION_bencoding +binary :: Serialize a => BKey -> BE.Get [a] +binary k = field (req k) >>= either (fail . format) return . + runGet (many get) + where + format str = "fail to deserialize " ++ show k ++ " field: " ++ str + +instance Address ip => BEncode (NodeFound ip) where + toBEncode (NodeFound ns) = toDict $ + nodes_key .=! runPut (mapM_ put ns) + .: endDict + + -- TODO: handle IPv6 by reading the "nodes6" key (see bep 32) + fromBEncode bval = NodeFound <$> (traverse from4 =<< fromDict (binary nodes_key) bval) +#else +instance Serialize (Response (NodeFound ip)) where + get = do + count <- get :: Get Word8 + nodes <- sequence $ replicate (fromIntegral count) get + nonce <- get :: Get Tox.Nonce8 + return $ Response $ NodeFound nodes nonce + + put (Response (NodeFound nodes nonce)) = do + put (fromIntegral (length nodes) :: Word8) + mapM_ put nodes + put nonce + +#endif + +-- | \"q\" == \"find_node\" +instance (Address ip, Typeable ip) + => KRPC (Query (FindNode ip)) (Response (NodeFound ip)) where +#ifdef VERSION_bencoding + type Envelope (Query (FindNode ip)) (Response (NodeFound ip)) = BValue + seal = toBEncode + unseal = fromBEncode + method = "find_node" +#else + method = Method Tox.GetNodes -- response: Tox.SendNodes +#endif + +#ifdef VERSION_bencoding +{----------------------------------------------------------------------- +-- get_peers method +-----------------------------------------------------------------------} + +-- | Get peers associated with a torrent infohash. +newtype GetPeers ip = GetPeers InfoHash + deriving (Show, Eq, Typeable) + +info_hash_key :: BKey +info_hash_key = "info_hash" + +instance Typeable ip => BEncode (GetPeers ip) where + toBEncode (GetPeers ih) = toDict $ info_hash_key .=! ih .: endDict + fromBEncode = fromDict $ GetPeers <$>! info_hash_key + +type PeerList ip = Either [NodeInfo KMessageOf ip ()] [PeerAddr ip] + +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 :: PeerList ip + + -- | The token value is a required argument for a future + -- announce_peer query. + , grantedToken :: Token + } deriving (Show, Eq, Typeable) + +peers_key :: BKey +peers_key = "values" + +token_key :: BKey +token_key = "token" + +name_key :: BKey +name_key = "name" + +instance (Typeable ip, Serialize ip) => BEncode (GotPeers ip) where + toBEncode GotPeers {..} = toDict $ + 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 $ 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 + +-- | \"q" = \"get_peers\" +instance (Typeable ip, Serialize ip) => + KRPC (Query (GetPeers ip)) (Response (GotPeers ip)) where + type Envelope (Query (GetPeers ip)) (Response (GotPeers ip)) = BValue + seal = toBEncode + unseal = fromBEncode + method = "get_peers" + +{----------------------------------------------------------------------- +-- announce method +-----------------------------------------------------------------------} + +-- | Announce that the peer, controlling the querying node, is +-- downloading a torrent on a port. +data Announce = Announce + { -- | If set, the 'port' field should be ignored and the source + -- port of the UDP packet should be used as the peer's port + -- instead. This is useful for peers behind a NAT that may not + -- know their external port, and supporting uTP, they accept + -- incoming connections on the same port as the DHT port. + impliedPort :: Bool + + -- | infohash of the torrent; + , topic :: InfoHash + + -- | some clients announce the friendly name of the torrent here. + , announcedName :: Maybe ByteString + + -- | the port /this/ peer is listening; + , port :: PortNumber + + -- TODO: optional boolean "seed" key + + -- | received in response to a previous get_peers query. + , sessionToken :: Token + + } deriving (Show, Eq, Typeable) + +port_key :: BKey +port_key = "port" + +implied_port_key :: BKey +implied_port_key = "implied_port" + +instance BEncode Announce where + toBEncode Announce {..} = toDict $ + implied_port_key .=? flagField impliedPort + .: info_hash_key .=! topic + .: name_key .=? announcedName + .: port_key .=! port + .: token_key .=! sessionToken + .: endDict + where + flagField flag = if flag then Just (1 :: Int) else Nothing + + fromBEncode = fromDict $ do + Announce <$> (boolField <$> optional (field (req implied_port_key))) + <*>! info_hash_key + <*>? name_key + <*>! port_key + <*>! token_key + where + boolField = maybe False (/= (0 :: Int)) + +-- | 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 + deriving (Show, Eq, Typeable) + +instance BEncode Announced where + toBEncode _ = toBEncode Ping + fromBEncode _ = pure Announced + +-- | \"q" = \"announce\" +instance KRPC (Query Announce) (Response Announced) where + type Envelope (Query Announce) (Response Announced) = BValue + seal = toBEncode + unseal = fromBEncode + method = "announce_peer" + +-- endif VERSION_bencoding +#endif + +-- | Yields all 8 DHT neighborhoods available to you given a particular ip +-- address. +bep42s :: Address a => a -> NodeId KMessageOf -> [NodeId KMessageOf] +bep42s addr (NodeId r) = mapMaybe (bep42 addr) rs + where + rs = map (NodeId . change3bits r) [0..7] + +-- change3bits :: ByteString -> Word8 -> ByteString +-- change3bits bs n = BS.snoc (BS.init bs) (BS.last bs .&. 0xF8 .|. n) + +change3bits :: (Num b, Bits b) => b -> b -> b +change3bits bs n = (bs .&. complement 7) .|. n + +-- | Modifies a purely random 'NodeId' to one that is related to a given +-- routable address in accordance with BEP 42. +bep42 :: Address a => a -> NodeId KMessageOf -> Maybe (NodeId KMessageOf) +bep42 addr (NodeId r) + | Just ip <- fmap S.encode (fromAddr addr :: Maybe IPv4) + <|> fmap S.encode (fromAddr addr :: Maybe IPv6) + = genBucketSample' retr (NodeId $ crc $ applyMask ip) (3,0x07,0) + | otherwise + = Nothing + where + ip4mask = "\x03\x0f\x3f\xff" :: ByteString + ip6mask = "\x01\x03\x07\x0f\x1f\x3f\x7f\xff" :: ByteString + nbhood_select = (fromIntegral r :: Word8) .&. 7 + retr n = pure $ BS.drop (nodeIdSize - n) $ S.encode r + crc = flip shiftL (finiteBitSize (NodeId undefined) - 32) . fromIntegral . crc32c . BS.pack + applyMask ip = case BS.zipWith (.&.) msk ip of + (b:bs) -> (b .|. shiftL nbhood_select 5) : bs + bs -> bs + where msk | BS.length ip == 4 = ip4mask + | otherwise = ip6mask + -- cgit v1.2.3