blob: 155a50cad84357ef55b4500692b0397ec09f9faf (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
|
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
module Network.BitTorrent.DHT
( dht
, ping
, Network.BitTorrent.DHT.bootstrap
, Network.BitTorrent.DHT.lookup
, Network.BitTorrent.DHT.insert
) where
import Control.Applicative
import Control.Concurrent.Lifted
import Control.Exception.Lifted
import Control.Monad
import Control.Monad.Logger
import Data.List as L
import Data.Monoid
import Data.Text as T
import Network.Socket (PortNumber)
import System.Timeout.Lifted
import Text.PrettyPrint as PP hiding ((<>))
import Text.PrettyPrint.Class
import Data.Torrent.InfoHash
import Network.BitTorrent.Core
import Network.BitTorrent.DHT.Message
import Network.BitTorrent.DHT.Session
{-----------------------------------------------------------------------
-- Handlers
-----------------------------------------------------------------------}
pingH :: Address ip => NodeHandler ip
pingH = nodeHandler $ \ _ Ping -> do
$(logDebug) "ping received, sending pong"
return Ping
findNodeH :: Address ip => NodeHandler ip
findNodeH = nodeHandler $ \ _ (FindNode nid) -> do
$(logDebug) "find_node received, sending closest nodes back"
NodeFound <$> getClosest nid
getPeersH :: Address ip => NodeHandler ip
getPeersH = nodeHandler $ \ naddr (GetPeers ih) -> do
$(logDebug) "get_peers received, trying to find peers"
GotPeers <$> getPeerList ih <*> grantToken naddr
announceH :: Address ip => NodeHandler ip
announceH = nodeHandler $ \ naddr (Announce {..}) -> do
$(logDebug) "announce received, trying to check token"
checkToken naddr sessionToken
case fromAddr naddr of
Nothing -> undefined
Just paddr -> do
insertPeer topic paddr
return Announced
handlers :: Address ip => [NodeHandler ip]
handlers = [pingH, findNodeH, getPeersH, announceH]
{-----------------------------------------------------------------------
-- Query
-----------------------------------------------------------------------}
-- | Run DHT on specified port. <add note about resources>
dht :: Address ip => NodeAddr ip -> DHT ip a -> IO a
dht addr = runDHT addr handlers
ping :: Address ip => NodeAddr ip -> DHT ip ()
ping addr = do
Ping <- Ping <@> addr
return ()
-- TODO fork?
-- | One good node may be sufficient. <note about 'Data.Torrent.tNodes'>
bootstrap :: Address ip => [NodeAddr ip] -> DHT ip ()
bootstrap startNodes = do
$(logInfoS) "bootstrap" "Start node bootstrapping"
mapM_ insertClosest startNodes
$(logInfoS) "bootstrap" "Node bootstrapping finished"
where
insertClosest addr = do
nid <- getNodeId
result <- try $ timeout 1000000 $ FindNode nid <@> addr
case result of
Left e -> do
$(logWarnS) "bootstrap" $ T.pack $ show (e :: IOError)
Right Nothing -> do
$(logWarnS) "bootstrap" $ "not responding @ "
<> T.pack (show (pretty addr))
Right (Just (NodeFound closest)) -> do
$(logDebug) ("Get a list of closest nodes: " <>
T.pack (PP.render (pretty closest)))
forM_ (L.take 2 closest) $ \ info @ NodeInfo {..} -> do
insertNode info
let prettyAddr = T.pack (show (pretty nodeAddr))
$(logInfoS) "bootstrap" $ "table detalization" <> prettyAddr
fork $ insertClosest nodeAddr
-- | Get list of peers which downloading
lookup :: Address ip => InfoHash -> DHT ip [PeerAddr ip]
lookup ih = getClosestHash ih >>= collect
where
collect nodes = L.concat <$> forM (nodeAddr <$> nodes) retrieve
retrieve addr = do
GotPeers {..} <- GetPeers ih <@> addr
either collect pure peers
-- | Announce that /this/ peer may have some pieces of the specified
-- torrent.
insert :: Address ip => InfoHash -> PortNumber -> DHT ip ()
insert ih port = do
nodes <- getClosestHash ih
forM_ (nodeAddr <$> nodes) $ \ addr -> do
-- GotPeers {..} <- GetPeers ih <@> addr
-- Announced <- Announce False ih undefined grantedToken <@> addr
return ()
|
