path: root/src/Network/BitTorrent/DHT/Message.hs

-- |
--   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.BitTorrent.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:
--   <http://www.bittorrent.org/beps/bep_0005.html#dht-queries>
--
--   For Kamelia messages see original Kademlia paper:
--   <http://pdos.csail.mit.edu/~petar/papers/maymounkov-kademlia-lncs.pdf>
--
{-# 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 (..)


#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
#else
import qualified Network.DatagramServer.Tox as Tox
import Network.DatagramServer.Tox (NodeId)
import Data.Word
import Control.Monad
import Network.KRPC.Method
#endif
import Network.BitTorrent.Address hiding (NodeId)
import Data.ByteString (ByteString)
import Data.List as L
import Data.Monoid
import Data.Serialize as S
import Data.Typeable
import Network
import Network.DatagramServer
import Network.DatagramServer.Mainline (KMessageOf)
import Data.Maybe

import Data.Torrent (InfoHash)
import Network.BitTorrent.DHT.Token
#ifdef VERSION_bencoding
import Network.DatagramServer ()
import Network.DHT.Mainline ()
#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