diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/Network/BitTorrent.hs | 3 | ||||
-rw-r--r-- | src/Network/BitTorrent/Discovery.hs | 59 | ||||
-rw-r--r-- | src/Network/BitTorrent/Sessions.hs | 108 |
3 files changed, 74 insertions, 96 deletions
diff --git a/src/Network/BitTorrent.hs b/src/Network/BitTorrent.hs index c68cceac..7c1e02e2 100644 --- a/src/Network/BitTorrent.hs +++ b/src/Network/BitTorrent.hs | |||
@@ -89,7 +89,6 @@ import Network.BitTorrent.Extension | |||
89 | import Network.BitTorrent.Exchange | 89 | import Network.BitTorrent.Exchange |
90 | import Network.BitTorrent.Exchange.Protocol | 90 | import Network.BitTorrent.Exchange.Protocol |
91 | import Network.BitTorrent.Tracker | 91 | import Network.BitTorrent.Tracker |
92 | import Network.BitTorrent.Discovery | ||
93 | 92 | ||
94 | import System.Torrent.Storage | 93 | import System.Torrent.Storage |
95 | 94 | ||
@@ -100,8 +99,6 @@ import System.Torrent.Storage | |||
100 | withDefaultClient :: PortNumber -> PortNumber -> (ClientSession -> IO ()) -> IO () | 99 | withDefaultClient :: PortNumber -> PortNumber -> (ClientSession -> IO ()) -> IO () |
101 | withDefaultClient dhtPort listPort action = do | 100 | withDefaultClient dhtPort listPort action = do |
102 | withClientSession defaultThreadCount defaultExtensions $ \client -> do | 101 | withClientSession defaultThreadCount defaultExtensions $ \client -> do |
103 | startListener client listPort | ||
104 | startDHT client dhtPort | ||
105 | action client | 102 | action client |
106 | 103 | ||
107 | {----------------------------------------------------------------------- | 104 | {----------------------------------------------------------------------- |
diff --git a/src/Network/BitTorrent/Discovery.hs b/src/Network/BitTorrent/Discovery.hs deleted file mode 100644 index 8403461c..00000000 --- a/src/Network/BitTorrent/Discovery.hs +++ /dev/null | |||
@@ -1,59 +0,0 @@ | |||
1 | {-# LANGUAGE RecordWildCards #-} | ||
2 | {-# LANGUAGE OverloadedStrings #-} | ||
3 | module Network.BitTorrent.Discovery | ||
4 | (discover, startListener, startDHT | ||
5 | ) where | ||
6 | |||
7 | import Control.Monad | ||
8 | import Control.Concurrent | ||
9 | import Control.Exception | ||
10 | import Network.Socket | ||
11 | |||
12 | import Data.Torrent | ||
13 | import Network.BitTorrent.Peer | ||
14 | import Network.BitTorrent.Sessions | ||
15 | import Network.BitTorrent.Exchange | ||
16 | import Network.BitTorrent.Tracker | ||
17 | import Network.BitTorrent.DHT | ||
18 | |||
19 | |||
20 | -- discover should hide tracker and DHT communication under the hood | ||
21 | -- thus we can obtain an unified interface | ||
22 | |||
23 | discover :: SwarmSession -> P2P () -> IO () | ||
24 | discover swarm @ SwarmSession {..} action = {-# SCC discover #-} do | ||
25 | port <- listenerPort clientSession | ||
26 | |||
27 | let conn = TConnection { | ||
28 | tconnAnnounce = tAnnounce torrentMeta | ||
29 | , tconnInfoHash = tInfoHash torrentMeta | ||
30 | , tconnPeerId = clientPeerId clientSession | ||
31 | , tconnPort = port | ||
32 | } | ||
33 | |||
34 | progress <- getCurrentProgress clientSession | ||
35 | |||
36 | withTracker progress conn $ \tses -> do | ||
37 | forever $ do | ||
38 | addr <- getPeerAddr tses | ||
39 | forkThrottle swarm $ do | ||
40 | initiatePeerSession swarm addr $ \conn -> | ||
41 | runP2P conn action | ||
42 | |||
43 | |||
44 | startListener :: ClientSession -> PortNumber -> IO () | ||
45 | startListener cs @ ClientSession {..} port = | ||
46 | startService peerListener port $ listener cs $ \conn @ (sock, PeerSession{..}) -> do | ||
47 | print "accepted" | ||
48 | let storage = error "storage" | ||
49 | runP2P conn (exchange storage) | ||
50 | |||
51 | startDHT :: ClientSession -> PortNumber -> IO () | ||
52 | startDHT ClientSession {..} nodePort = withRunning peerListener failure start | ||
53 | where | ||
54 | start ClientService {..} = do | ||
55 | ses <- newNodeSession servPort | ||
56 | startService nodeListener nodePort (dhtServer ses) | ||
57 | |||
58 | failure = throwIO $ userError msg | ||
59 | msg = "unable to start DHT server: peer listener is not running" | ||
diff --git a/src/Network/BitTorrent/Sessions.hs b/src/Network/BitTorrent/Sessions.hs index 31b30e43..da57ec3b 100644 --- a/src/Network/BitTorrent/Sessions.hs +++ b/src/Network/BitTorrent/Sessions.hs | |||
@@ -19,47 +19,44 @@ module Network.BitTorrent.Sessions | |||
19 | , clientPeerId, allowedExtensions | 19 | , clientPeerId, allowedExtensions |
20 | , nodeListener, peerListener | 20 | , nodeListener, peerListener |
21 | ) | 21 | ) |
22 | , withClientSession | 22 | , withClientSession |
23 | , listenerPort, dhtPort | 23 | , listenerPort, dhtPort |
24 | 24 | ||
25 | , ThreadCount | 25 | , ThreadCount |
26 | , defaultThreadCount | 26 | , defaultThreadCount |
27 | 27 | ||
28 | , TorrentLoc(..) | 28 | , TorrentLoc(..) |
29 | , registerTorrent | 29 | , registerTorrent |
30 | , unregisterTorrent | 30 | , unregisterTorrent |
31 | 31 | ||
32 | , getCurrentProgress | 32 | , getCurrentProgress |
33 | , getSwarmCount | 33 | , getSwarmCount |
34 | , getPeerCount | 34 | , getPeerCount |
35 | 35 | ||
36 | -- * Swarm | 36 | -- * Swarm |
37 | , SwarmSession( SwarmSession, torrentMeta, clientSession ) | 37 | , SwarmSession( SwarmSession, torrentMeta, clientSession ) |
38 | 38 | ||
39 | , SessionCount | 39 | , SessionCount |
40 | , getSessionCount | 40 | , getSessionCount |
41 | 41 | ||
42 | , newLeecher | 42 | , newLeecher |
43 | , newSeeder | 43 | , newSeeder |
44 | , getClientBitfield | 44 | , getClientBitfield |
45 | 45 | ||
46 | -- TODO hide this | 46 | -- * Peer |
47 | , waitVacancy | 47 | , PeerSession( PeerSession, connectedPeerAddr |
48 | , forkThrottle | 48 | , swarmSession, enabledExtensions |
49 | , sessionState | ||
50 | ) | ||
51 | , SessionState | ||
52 | , initiatePeerSession | ||
53 | , acceptPeerSession | ||
54 | , listener | ||
49 | 55 | ||
50 | -- * Peer | 56 | -- * Timeouts |
51 | , PeerSession( PeerSession, connectedPeerAddr | 57 | , updateIncoming, updateOutcoming |
52 | , swarmSession, enabledExtensions | 58 | , discover |
53 | , sessionState | 59 | ) where |
54 | ) | ||
55 | , SessionState | ||
56 | , initiatePeerSession | ||
57 | , acceptPeerSession | ||
58 | , listener | ||
59 | |||
60 | -- * Timeouts | ||
61 | , updateIncoming, updateOutcoming | ||
62 | ) where | ||
63 | 60 | ||
64 | import Prelude hiding (mapM_) | 61 | import Prelude hiding (mapM_) |
65 | 62 | ||
@@ -90,10 +87,13 @@ import Data.Bitfield as BF | |||
90 | import Data.Torrent | 87 | import Data.Torrent |
91 | import Network.BitTorrent.Extension | 88 | import Network.BitTorrent.Extension |
92 | import Network.BitTorrent.Peer | 89 | import Network.BitTorrent.Peer |
90 | import Network.BitTorrent.Sessions.Types | ||
93 | import Network.BitTorrent.Exchange.Protocol as BT | 91 | import Network.BitTorrent.Exchange.Protocol as BT |
94 | import Network.BitTorrent.Tracker.Protocol as BT | 92 | import Network.BitTorrent.Tracker.Protocol as BT |
93 | import Network.BitTorrent.Tracker as BT | ||
94 | import Network.BitTorrent.Exchange as BT | ||
95 | import Network.BitTorrent.DHT as BT | ||
95 | import System.Torrent.Storage | 96 | import System.Torrent.Storage |
96 | import Network.BitTorrent.Sessions.Types | ||
97 | 97 | ||
98 | {----------------------------------------------------------------------- | 98 | {----------------------------------------------------------------------- |
99 | Client Services | 99 | Client Services |
@@ -134,6 +134,23 @@ torrentPresence ClientSession {..} ih = do | |||
134 | Client sessions | 134 | Client sessions |
135 | -----------------------------------------------------------------------} | 135 | -----------------------------------------------------------------------} |
136 | 136 | ||
137 | startListener :: ClientSession -> PortNumber -> IO () | ||
138 | startListener cs @ ClientSession {..} port = | ||
139 | startService peerListener port $ listener cs $ \conn @ (sock, PeerSession{..}) -> do | ||
140 | print "accepted" | ||
141 | let storage = error "storage" | ||
142 | runP2P conn (exchange storage) | ||
143 | |||
144 | startDHT :: ClientSession -> PortNumber -> IO () | ||
145 | startDHT ClientSession {..} nodePort = withRunning peerListener failure start | ||
146 | where | ||
147 | start ClientService {..} = do | ||
148 | ses <- newNodeSession servPort | ||
149 | startService nodeListener nodePort (dhtServer ses) | ||
150 | |||
151 | failure = throwIO $ userError msg | ||
152 | msg = "unable to start DHT server: peer listener is not running" | ||
153 | |||
137 | -- | Create a new client session. The data passed to this function are | 154 | -- | Create a new client session. The data passed to this function are |
138 | -- usually loaded from configuration file. | 155 | -- usually loaded from configuration file. |
139 | openClientSession :: SessionCount -- ^ Maximum count of active P2P Sessions. | 156 | openClientSession :: SessionCount -- ^ Maximum count of active P2P Sessions. |
@@ -194,6 +211,29 @@ defSeederConns = defaultUnchokeSlots | |||
194 | defLeacherConns :: SessionCount | 211 | defLeacherConns :: SessionCount |
195 | defLeacherConns = defaultNumWant | 212 | defLeacherConns = defaultNumWant |
196 | 213 | ||
214 | -- discovery should hide tracker and DHT communication under the hood | ||
215 | -- thus we can obtain an unified interface | ||
216 | |||
217 | discover :: SwarmSession -> P2P () -> IO () | ||
218 | discover swarm @ SwarmSession {..} action = {-# SCC discover #-} do | ||
219 | port <- listenerPort clientSession | ||
220 | |||
221 | let conn = TConnection { | ||
222 | tconnAnnounce = tAnnounce torrentMeta | ||
223 | , tconnInfoHash = tInfoHash torrentMeta | ||
224 | , tconnPeerId = clientPeerId clientSession | ||
225 | , tconnPort = port | ||
226 | } | ||
227 | |||
228 | progress <- getCurrentProgress clientSession | ||
229 | |||
230 | withTracker progress conn $ \tses -> do | ||
231 | forever $ do | ||
232 | addr <- getPeerAddr tses | ||
233 | forkThrottle swarm $ do | ||
234 | initiatePeerSession swarm addr $ \conn -> | ||
235 | runP2P conn action | ||
236 | |||
197 | newSwarmSession :: Int -> Bitfield -> ClientSession -> Torrent | 237 | newSwarmSession :: Int -> Bitfield -> ClientSession -> Torrent |
198 | -> IO SwarmSession | 238 | -> IO SwarmSession |
199 | newSwarmSession n bf cs @ ClientSession {..} t @ Torrent {..} | 239 | newSwarmSession n bf cs @ ClientSession {..} t @ Torrent {..} |