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
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
-- |
-- Copyright : (c) Sam T. 2013
-- License : MIT
-- Maintainer : pxqr.sta@gmail.com
-- Stability : experimental
-- Portability : portable
--
{-# LANGUAGE RecordWildCards #-}
module Network.BitTorrent
(
module Data.Torrent
-- * Session
, ThreadCount
, defaultThreadCount
-- ** Client
, ClientSession( clientPeerID, allowedExtensions )
, newClient
, defaultClient
, getCurrentProgress
, getPeerCount
, getSwarmCount
-- ** Swarm
, SwarmSession(torrentMeta)
, newLeecher
, newSeeder
, SessionCount
, getSessionCount
-- * Storage
, Storage
, ppStorage
, bindTo
, unbind
-- * Discovery
, discover
, exchange
-- * Peer to Peer
, P2P
-- ** Session
, PeerSession( PeerSession, connectedPeerAddr
, swarmSession, enabledExtensions
)
, getHaveCount
, getWantCount
, getPieceCount
-- ** Transfer
, Block(..), ppBlock
, BlockIx(..), ppBlockIx
-- ** Control
, SessionException
, disconnect
, protocolError
-- ** Events
, Event(..)
, awaitEvent, yieldEvent
-- * Extensions
, Extension, defaultExtensions, ppExtension
) where
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.Reader
import Network
import Data.Bitfield as BF
import Data.Torrent
import Network.BitTorrent.Internal
import Network.BitTorrent.Exchange
import Network.BitTorrent.Exchange.Protocol
import Network.BitTorrent.Tracker
import Network.BitTorrent.Extension
import Network.BitTorrent.Peer
import System.Torrent.Storage
-- | Client session with default parameters. Use it for testing only.
defaultClient :: IO ClientSession
defaultClient = newClient defaultThreadCount defaultExtensions
-- discover should hide tracker and DHT communication under the hood
-- thus we can obtain an unified interface
discover :: SwarmSession -> P2P () -> IO ()
discover swarm action = do
port <- forkListener (error "discover")
let conn = TConnection (tAnnounce (torrentMeta swarm))
(tInfoHash (torrentMeta swarm))
(clientPeerID (clientSession swarm))
port
progress <- getCurrentProgress (clientSession swarm)
withTracker progress conn $ \tses -> do
forever $ do
addr <- getPeerAddr tses
spawnP2P swarm addr $ do
action
-- Event translation table looks like:
--
-- Available -> Want
-- Want -> Fragment
-- Fragment -> Available
--
-- If we join the chain we get the event loop:
--
-- Available -> Want -> Fragment --\
-- /|\ |
-- \---------------------------/
--
-- | Default P2P action.
exchange :: Storage -> P2P ()
exchange storage = awaitEvent >>= handler
where
handler (Available bf) = do
liftIO (print (completeness bf))
ixs <- selBlk (findMin bf) storage
mapM_ (yieldEvent . Want) ixs -- TODO yield vectored
handler (Want bix) = do
blk <- liftIO $ getBlk bix storage
yieldEvent (Fragment blk)
handler (Fragment blk @ Block {..}) = do
liftIO $ print (ppBlock blk)
done <- liftIO $ putBlk blk storage
when done $ do
yieldEvent $ Available $ singleton blkPiece (succ blkPiece)
offer <- peerOffer
if BF.null offer
then return ()
else handler (Available offer)
|
