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
|
-- |
-- 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.
--
{-# LANGUAGE RecordWildCards #-}
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.Internal
import Network.BitTorrent.Peer
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)
-- | 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 [PeerAddr]
}
newSession :: Progress -> Int -> [PeerAddr] -> IO TSession
newSession pr i ps = TSession <$> newTVarIO pr
<*> newIORef i
<*> newTVarIO ps
getPeerList :: TSession -> IO [PeerAddr]
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
resp <- askTracker (startedReq conn initProgress)
se <- newSession initProgress (respInterval resp) (respPeers resp)
tid <- forkIO (syncSession se)
return (se, tid)
syncSession se @ TSession {..} = forever $ do
waitInterval se
pr <- getProgress se
resp <- tryJust isIOException $ do
askTracker (regularReq defaultNumWant conn pr)
case resp of
Right (OK {..}) -> do
writeIORef seInterval respInterval
atomically $ writeTVar sePeers respPeers
_ -> return ()
where
isIOException :: IOException -> Maybe IOException
isIOException = return
end (se, tid) = do
killThread tid
pr <- getProgress se
askTracker $ stoppedReq conn pr
|
