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
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
|
-- |
-- Copyright : (c) Sam T. 2013
-- License : MIT
-- Maintainer : pxqr.sta@gmail.com
-- Stability : experimental
-- Portability : non-portable
--
-- This module provides high level API for peer->tracker
-- communication.
--
module Network.BitTorrent.Tracker
( module Network.BitTorrent.Tracker.Scrape
, withTracker, completedReq
-- * Progress
, Progress(..), startProgress
-- * Connection
, TConnection(..), tconnection
-- * Session
, TSession, getPeerList, getProgress, waitInterval
-- * Re-export
, defaultPorts
) where
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Data.IORef
import Data.Torrent
import Network
import Network.URI
import Network.BitTorrent.Peer
import Network.BitTorrent.PeerID
import Network.BitTorrent.Tracker.Protocol
import Network.BitTorrent.Tracker.Scrape
-- | 'TConnection' (shorthand for Tracker session) combines tracker request
-- fields neccessary for tracker, torrent and client identification.
--
-- This data is considered as static within one session.
--
data TConnection = TConnection {
tconnAnnounce :: URI -- ^ Announce URL.
, tconnInfoHash :: InfoHash -- ^ Hash of info part of current .torrent file.
, tconnPeerID :: PeerID -- ^ Client peer ID.
, tconnPort :: PortNumber -- ^ The port number the client is listenning on.
} deriving Show
tconnection :: Torrent -> PeerID -> PortNumber -> TConnection
tconnection t = TConnection (tAnnounce t) (tInfoHash t)
-- | 'Progress' contains upload/download/left stats about
-- current client state.
--
-- This data is considered as dynamic within one session.
--
data Progress = Progress {
prUploaded :: Integer -- ^ Total amount of bytes uploaded.
, prDownloaded :: Integer -- ^ Total amount of bytes downloaded.
, prLeft :: Integer -- ^ Total amount of bytes left.
} deriving Show
startProgress :: Integer -> Progress
startProgress = Progress 0 0
-- | used to avoid boilerplate; do NOT export me
genericReq :: TConnection -> Progress -> TRequest
genericReq ses pr = TRequest {
reqAnnounce = tconnAnnounce ses
, reqInfoHash = tconnInfoHash ses
, reqPeerID = tconnPeerID ses
, reqPort = tconnPort ses
, reqUploaded = prUploaded pr
, reqDownloaded = prDownloaded pr
, reqLeft = prLeft pr
, reqIP = Nothing
, reqNumWant = Nothing
, reqEvent = Nothing
}
-- | The first request to the tracker that should be created is 'startedReq'.
-- It includes necessary 'Started' event field.
--
startedReq :: TConnection -> Progress -> TRequest
startedReq ses pr = (genericReq ses pr) {
reqIP = Nothing
, reqNumWant = Just defaultNumWant
, reqEvent = Just Started
}
-- | Regular request must be sent to keep track new peers and
-- notify tracker about current state of the client
-- so new peers could connect to the client.
--
regularReq :: Int -> TConnection -> Progress -> TRequest
regularReq numWant ses pr = (genericReq ses pr) {
reqIP = Nothing
, reqNumWant = Just numWant
, reqEvent = Nothing
}
-- | Must be sent to the tracker if the client is shutting down gracefully.
--
stoppedReq :: TConnection -> Progress -> TRequest
stoppedReq ses pr = (genericReq ses pr) {
reqIP = Nothing
, reqNumWant = Nothing
, reqEvent = Just Stopped
}
-- | Must be sent to the tracker when the download completes.
-- However, must not be sent if the download was already 100% complete.
--
completedReq :: TConnection -> Progress -> TRequest
completedReq ses pr = (genericReq ses pr) {
reqIP = Nothing
, reqNumWant = Nothing
, reqEvent = Just Completed
}
data TSession = TSession {
seProgress :: TVar Progress
, seInterval :: IORef Int
, sePeers :: TVar [Peer]
}
newSession :: Progress -> Int -> [Peer] -> IO TSession
newSession pr i ps = TSession <$> newTVarIO pr <*> newIORef i <*> newTVarIO ps
getPeerList :: TSession -> IO [Peer]
getPeerList = readTVarIO . sePeers
getProgress :: TSession -> IO Progress
getProgress = readTVarIO . seProgress
waitInterval :: TSession -> IO ()
waitInterval = readIORef . seInterval >=> threadDelay
withTracker :: Progress -> TConnection -> (TSession -> IO a) -> IO a
withTracker initProgress conn action = bracket start end (action . fst)
where
start = do
res <- sendRequest (startedReq conn initProgress)
case res of
Left err -> ioError (userError err)
Right (Failure err) -> ioError (userError (show err))
Right resp -> do
se <- newSession initProgress (respInterval resp) (respPeers resp)
tid <- forkIO (syncSession se)
return (se, tid)
syncSession se = do
waitInterval se
pr <- getProgress se
eresp <- sendRequest (regularReq defaultNumWant conn pr)
case eresp of
Right (OK { respInterval = i, respPeers = ps }) -> do
writeIORef (seInterval se) i
atomically $ writeTVar (sePeers se) ps
_ -> return ()
syncSession se
end (se, tid) = do
killThread tid
getProgress se >>= sendRequest . stoppedReq conn
|
