Rename Network.BitTorrent.DHT.Message -> Network.DHT.Mainline

1 files changed, 509 insertions, 0 deletions

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:
+--   <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.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
+