diff options
Diffstat (limited to 'src/Network')
-rw-r--r-- | src/Network/BitTorrent.hs | 43 | ||||
-rw-r--r-- | src/Network/BitTorrent/Exchange.hs | 1 | ||||
-rw-r--r-- | src/Network/BitTorrent/Internal.hs | 26 |
3 files changed, 48 insertions, 22 deletions
diff --git a/src/Network/BitTorrent.hs b/src/Network/BitTorrent.hs index c37129cb..8f0f42ce 100644 --- a/src/Network/BitTorrent.hs +++ b/src/Network/BitTorrent.hs | |||
@@ -7,35 +7,50 @@ | |||
7 | -- | 7 | -- |
8 | {-# LANGUAGE RecordWildCards #-} | 8 | {-# LANGUAGE RecordWildCards #-} |
9 | module Network.BitTorrent | 9 | module Network.BitTorrent |
10 | ( module BT | 10 | ( |
11 | , module Data.Torrent | 11 | module Data.Torrent |
12 | 12 | ||
13 | -- * Tracker | 13 | -- * Session |
14 | , ClientSession | ||
15 | , newClient | ||
14 | 16 | ||
15 | -- * P2P | 17 | , SwarmSession |
16 | , ClientSession, newClient | 18 | , newLeacher, newSeeder |
17 | , SwarmSession, newLeacher, newSeeder | 19 | |
18 | , PeerSession | 20 | -- * Discovery |
19 | , discover | 21 | , discover |
22 | |||
23 | -- * Peer to Peer | ||
24 | , P2P, PeerSession | ||
25 | ( connectedPeerAddr, enabledExtensions | ||
26 | , peerBitfield, peerSessionStatus | ||
27 | ) | ||
28 | |||
29 | , awaitEvent, signalEvent | ||
20 | ) where | 30 | ) where |
21 | 31 | ||
32 | import Control.Monad | ||
22 | import Data.IORef | 33 | import Data.IORef |
23 | 34 | ||
24 | import Data.Torrent | 35 | import Data.Torrent |
25 | import Network.BitTorrent.Internal | 36 | import Network.BitTorrent.Internal |
26 | import Network.BitTorrent.Extension as BT | 37 | import Network.BitTorrent.Exchange |
27 | import Network.BitTorrent.Peer as BT | 38 | import Network.BitTorrent.Tracker |
28 | import Network.BitTorrent.Exchange as BT | 39 | |
29 | import Network.BitTorrent.Tracker as BT | 40 | |
30 | 41 | ||
31 | -- discover should hide tracker and DHT communication under the hood | 42 | -- discover should hide tracker and DHT communication under the hood |
32 | -- thus we can obtain unified interface | 43 | -- thus we can obtain unified interface |
33 | 44 | ||
34 | discover :: SwarmSession -> (TSession -> IO a) -> IO a | 45 | discover :: SwarmSession -> P2P () -> IO () |
35 | discover SwarmSession {..} action = do | 46 | discover swarm @ SwarmSession {..} action = do |
36 | let conn = TConnection (tAnnounce torrentMeta) (tInfoHash torrentMeta) | 47 | let conn = TConnection (tAnnounce torrentMeta) (tInfoHash torrentMeta) |
37 | (clientPeerID clientSession) port | 48 | (clientPeerID clientSession) port |
38 | progress <- readIORef (currentProgress clientSession) | 49 | progress <- readIORef (currentProgress clientSession) |
39 | withTracker progress conn action | 50 | withTracker progress conn $ \tses -> do |
51 | forever $ do | ||
52 | addr <- getPeerAddr tses | ||
53 | withPeer swarm addr action | ||
54 | |||
40 | 55 | ||
41 | port = 10000 | 56 | port = 10000 |
diff --git a/src/Network/BitTorrent/Exchange.hs b/src/Network/BitTorrent/Exchange.hs index dd1f9d0b..2173cf8b 100644 --- a/src/Network/BitTorrent/Exchange.hs +++ b/src/Network/BitTorrent/Exchange.hs | |||
@@ -45,6 +45,7 @@ import Data.Torrent | |||
45 | data Event = Available Bitfield | 45 | data Event = Available Bitfield |
46 | | Want | 46 | | Want |
47 | | Block | 47 | | Block |
48 | deriving Show | ||
48 | 49 | ||
49 | {----------------------------------------------------------------------- | 50 | {----------------------------------------------------------------------- |
50 | Peer wire | 51 | Peer wire |
diff --git a/src/Network/BitTorrent/Internal.hs b/src/Network/BitTorrent/Internal.hs index e231fb2c..39e10ce2 100644 --- a/src/Network/BitTorrent/Internal.hs +++ b/src/Network/BitTorrent/Internal.hs | |||
@@ -85,11 +85,16 @@ instance Ord ClientSession where | |||
85 | compare = comparing clientPeerID | 85 | compare = comparing clientPeerID |
86 | 86 | ||
87 | newClient :: [Extension] -> IO ClientSession | 87 | newClient :: [Extension] -> IO ClientSession |
88 | newClient exts = ClientSession <$> newPeerID | 88 | newClient exts = do |
89 | <*> pure exts | 89 | mgr <- Ev.new |
90 | <*> newTVarIO S.empty | 90 | forkIO $ loop mgr |
91 | <*> Ev.new | 91 | |
92 | <*> newIORef (startProgress 0) | 92 | ClientSession |
93 | <$> newPeerID | ||
94 | <*> pure exts | ||
95 | <*> newTVarIO S.empty | ||
96 | <*> pure mgr | ||
97 | <*> newIORef (startProgress 0) | ||
93 | 98 | ||
94 | {----------------------------------------------------------------------- | 99 | {----------------------------------------------------------------------- |
95 | Swarm session | 100 | Swarm session |
@@ -207,7 +212,7 @@ maxIncomingTime :: Int | |||
207 | maxIncomingTime = 120 * sec | 212 | maxIncomingTime = 120 * sec |
208 | 213 | ||
209 | maxOutcomingTime :: Int | 214 | maxOutcomingTime :: Int |
210 | maxOutcomingTime = 60 * sec | 215 | maxOutcomingTime = 1 * sec |
211 | 216 | ||
212 | -- | Should be called after we have received any message from a peer. | 217 | -- | Should be called after we have received any message from a peer. |
213 | updateIncoming :: PeerSession -> IO () | 218 | updateIncoming :: PeerSession -> IO () |
@@ -221,8 +226,13 @@ updateOutcoming PeerSession {..} = | |||
221 | updateTimeout (eventManager (clientSession swarmSession)) | 226 | updateTimeout (eventManager (clientSession swarmSession)) |
222 | outcomingTimeout maxOutcomingTime | 227 | outcomingTimeout maxOutcomingTime |
223 | 228 | ||
224 | sendKA :: Socket -> IO () | 229 | sendKA :: Socket -> SwarmSession -> IO () |
225 | sendKA sock = sendAll sock (encode BT.KeepAlive) | 230 | sendKA sock SwarmSession {..} = do |
231 | print "I'm sending keep alive." | ||
232 | sendAll sock (encode BT.KeepAlive) | ||
233 | let mgr = eventManager clientSession | ||
234 | updateTimeout mgr | ||
235 | print "Done.." | ||
226 | 236 | ||
227 | abortSession :: IO () | 237 | abortSession :: IO () |
228 | abortSession = error "abortSession: not implemented" | 238 | abortSession = error "abortSession: not implemented" |