Add DHT messages

1 files changed, 240 insertions, 0 deletions

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:
+--   <http://www.bittorrent.org/beps/bep_0005.html#dht-queries>
+--
+{-# 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