diff options
author | joe <joe@jerkface.net> | 2017-09-15 06:22:10 -0400 |
---|---|---|
committer | joe <joe@jerkface.net> | 2017-09-15 06:22:10 -0400 |
commit | 12cbb3af2413dc28838ed271351dda16df8f7bdb (patch) | |
tree | 2db77a787e18a81a8369a8d73fee369d8826f064 /bittorrent/src/Network/BitTorrent/Tracker/Session.hs | |
parent | 362357c6d08cbd8dffa627a1e80199dcb9ba231f (diff) |
Separating dht-client library from bittorrent package.
Diffstat (limited to 'bittorrent/src/Network/BitTorrent/Tracker/Session.hs')
-rw-r--r-- | bittorrent/src/Network/BitTorrent/Tracker/Session.hs | 306 |
1 files changed, 306 insertions, 0 deletions
diff --git a/bittorrent/src/Network/BitTorrent/Tracker/Session.hs b/bittorrent/src/Network/BitTorrent/Tracker/Session.hs new file mode 100644 index 00000000..aa4a832f --- /dev/null +++ b/bittorrent/src/Network/BitTorrent/Tracker/Session.hs | |||
@@ -0,0 +1,306 @@ | |||
1 | -- | | ||
2 | -- Copyright : (c) Sam Truzjan 2014 | ||
3 | -- License : BSD | ||
4 | -- Maintainer : pxqr.sta@gmail.com | ||
5 | -- Stability : experimental | ||
6 | -- Portability : portable | ||
7 | -- | ||
8 | -- Multitracker sessions. | ||
9 | -- | ||
10 | {-# LANGUAGE FlexibleInstances #-} | ||
11 | {-# LANGUAGE TypeFamilies #-} | ||
12 | {-# LANGUAGE TypeSynonymInstances #-} | ||
13 | {-# LANGUAGE TemplateHaskell #-} | ||
14 | module Network.BitTorrent.Tracker.Session | ||
15 | ( -- * Session | ||
16 | Session | ||
17 | , Event (..) | ||
18 | , newSession | ||
19 | , closeSession | ||
20 | , withSession | ||
21 | |||
22 | -- * Client send notifications | ||
23 | , notify | ||
24 | , askPeers | ||
25 | |||
26 | -- * Session state | ||
27 | -- ** Status | ||
28 | , Status (..) | ||
29 | , getStatus | ||
30 | |||
31 | -- ** Single tracker sessions | ||
32 | , LastScrape (..) | ||
33 | , TrackerSession | ||
34 | , trackerPeers | ||
35 | , trackerScrape | ||
36 | , getSessionState | ||
37 | |||
38 | -- * Tracker Exchange | ||
39 | -- | BEP28: <http://www.bittorrent.org/beps/bep_0028.html> | ||
40 | , addTracker | ||
41 | , removeTracker | ||
42 | , getTrustedTrackers | ||
43 | ) where | ||
44 | |||
45 | import Control.Applicative | ||
46 | import Control.Exception | ||
47 | import Control.Concurrent | ||
48 | import Control.Concurrent.Chan.Split as CS | ||
49 | import Control.Monad | ||
50 | import Data.Default | ||
51 | import Data.Fixed | ||
52 | import Data.Foldable as F | ||
53 | import Data.IORef | ||
54 | import Data.List as L | ||
55 | import Data.Maybe | ||
56 | import Data.Time | ||
57 | import Data.Traversable | ||
58 | import Network.URI | ||
59 | |||
60 | import Data.Torrent | ||
61 | import Network.Address | ||
62 | import Network.BitTorrent.Internal.Cache | ||
63 | import Network.BitTorrent.Internal.Types | ||
64 | import Network.BitTorrent.Tracker.List as TL | ||
65 | import Network.BitTorrent.Tracker.Message | ||
66 | import Network.BitTorrent.Tracker.RPC as RPC | ||
67 | |||
68 | {----------------------------------------------------------------------- | ||
69 | -- Single tracker session | ||
70 | -----------------------------------------------------------------------} | ||
71 | |||
72 | -- | Status of this client. | ||
73 | data Status | ||
74 | = Running -- ^ This client is announced and listenning for incoming | ||
75 | -- connections. | ||
76 | | Paused -- ^ This client does not expecting incoming connections. | ||
77 | deriving (Show, Eq, Bounded, Enum) | ||
78 | |||
79 | -- | Client starting in the paused state. | ||
80 | instance Default Status where | ||
81 | def = Paused | ||
82 | |||
83 | -- | Tracker session starts with scrape unknown. | ||
84 | instance Default LastScrape where | ||
85 | def = LastScrape Nothing Nothing | ||
86 | |||
87 | data LastScrape = LastScrape | ||
88 | { -- | Count of leechers the tracker aware of. | ||
89 | scrapeLeechers :: Maybe Int | ||
90 | |||
91 | -- | Count of seeders the tracker aware of. | ||
92 | , scrapeSeeders :: Maybe Int | ||
93 | } deriving (Show, Eq) | ||
94 | |||
95 | -- | Single tracker session. | ||
96 | data TrackerSession = TrackerSession | ||
97 | { -- | Used to notify 'Stopped' and 'Completed' events. | ||
98 | statusSent :: !(Maybe Status) | ||
99 | |||
100 | -- | Can be used to retrieve peer set. | ||
101 | , trackerPeers :: Cached [PeerAddr IP] | ||
102 | |||
103 | -- | Can be used to show brief swarm stats in client GUI. | ||
104 | , trackerScrape :: Cached LastScrape | ||
105 | } | ||
106 | |||
107 | -- | Not contacted. | ||
108 | instance Default TrackerSession where | ||
109 | def = TrackerSession Nothing def def | ||
110 | |||
111 | -- | Do we need to notify this /specific/ tracker? | ||
112 | needNotify :: AnnounceEvent -> Maybe Status -> Maybe Bool | ||
113 | needNotify Started Nothing = Just True | ||
114 | needNotify Stopped Nothing = Just False | ||
115 | needNotify Completed Nothing = Just False | ||
116 | needNotify Started (Just Running) = Nothing | ||
117 | needNotify Stopped (Just Running) = Just True | ||
118 | needNotify Completed (Just Running) = Just True | ||
119 | needNotify Started (Just Paused ) = Just True | ||
120 | needNotify Stopped (Just Paused ) = Just False | ||
121 | needNotify Completed (Just Paused ) = Just True | ||
122 | |||
123 | -- | Client status after event announce succeed. | ||
124 | nextStatus :: AnnounceEvent -> Maybe Status | ||
125 | nextStatus Started = Just Running | ||
126 | nextStatus Stopped = Just Paused | ||
127 | nextStatus Completed = Nothing -- must keep previous status | ||
128 | |||
129 | seconds :: Int -> NominalDiffTime | ||
130 | seconds n = realToFrac (toEnum n :: Uni) | ||
131 | |||
132 | cachePeers :: AnnounceInfo -> IO (Cached [PeerAddr IP]) | ||
133 | cachePeers AnnounceInfo {..} = | ||
134 | newCached (seconds respInterval) | ||
135 | (seconds (fromMaybe respInterval respMinInterval)) | ||
136 | (getPeerList respPeers) | ||
137 | |||
138 | cacheScrape :: AnnounceInfo -> IO (Cached LastScrape) | ||
139 | cacheScrape AnnounceInfo {..} = | ||
140 | newCached (seconds respInterval) | ||
141 | (seconds (fromMaybe respInterval respMinInterval)) | ||
142 | LastScrape | ||
143 | { scrapeSeeders = respComplete | ||
144 | , scrapeLeechers = respIncomplete | ||
145 | } | ||
146 | |||
147 | -- | Make announce request to specific tracker returning new state. | ||
148 | notifyTo :: Manager -> Session -> AnnounceEvent | ||
149 | -> TierEntry TrackerSession -> IO TrackerSession | ||
150 | notifyTo mgr s @ Session {..} event (uri, entry @ TrackerSession {..}) = do | ||
151 | let shouldNotify = needNotify event statusSent | ||
152 | mustNotify <- maybe (isExpired trackerPeers) return shouldNotify | ||
153 | if not mustNotify | ||
154 | then return entry | ||
155 | else do | ||
156 | let q = SAnnounceQuery sessionTopic def Nothing (Just event) | ||
157 | res <- RPC.announce mgr uri q | ||
158 | when (statusSent == Nothing) $ do | ||
159 | send sessionEvents (TrackerConfirmed uri) | ||
160 | send sessionEvents (AnnouncedTo uri) | ||
161 | let status' = nextStatus event <|> statusSent | ||
162 | TrackerSession status' <$> cachePeers res <*> cacheScrape res | ||
163 | |||
164 | {----------------------------------------------------------------------- | ||
165 | -- Multitracker Session | ||
166 | -----------------------------------------------------------------------} | ||
167 | |||
168 | -- | Multitracker session. | ||
169 | data Session = Session | ||
170 | { -- | Infohash to announce at each 'announce' request. | ||
171 | sessionTopic :: !InfoHash | ||
172 | |||
173 | -- | Current status of this client is used to filter duplicated | ||
174 | -- notifications, for e.g. we don't want to notify a tracker with | ||
175 | -- ['Stopped', 'Stopped'], the last should be ignored. | ||
176 | , sessionStatus :: !(IORef Status) | ||
177 | |||
178 | -- | A set of single-tracker sessions. Any request to a tracker | ||
179 | -- must take a lock. | ||
180 | , sessionTrackers :: !(MVar (TrackerList TrackerSession)) | ||
181 | |||
182 | , sessionEvents :: !(SendPort (Event Session)) | ||
183 | } | ||
184 | |||
185 | instance EventSource Session where | ||
186 | data Event Session | ||
187 | = TrackerAdded URI | ||
188 | | TrackerConfirmed URI | ||
189 | | TrackerRemoved URI | ||
190 | | AnnouncedTo URI | ||
191 | | SessionClosed | ||
192 | |||
193 | listen Session {..} = CS.listen sessionEvents | ||
194 | |||
195 | |||
196 | -- | Create a new multitracker session in paused state. Tracker list | ||
197 | -- must contant only /trusted/ tracker uris. To start announcing | ||
198 | -- client presence use 'notify'. | ||
199 | newSession :: InfoHash -> TrackerList () -> IO Session | ||
200 | newSession ih origUris = do | ||
201 | urisList <- shuffleTiers origUris | ||
202 | statusRef <- newIORef def | ||
203 | entriesVar <- newMVar (fmap (const def) urisList) | ||
204 | eventStream <- newSendPort | ||
205 | return Session | ||
206 | { sessionTopic = ih | ||
207 | , sessionStatus = statusRef | ||
208 | , sessionTrackers = entriesVar | ||
209 | , sessionEvents = eventStream | ||
210 | } | ||
211 | |||
212 | -- | Release scarce resources associated with the given session. This | ||
213 | -- function block until all trackers tied with this peer notified with | ||
214 | -- 'Stopped' event. | ||
215 | closeSession :: Manager -> Session -> IO () | ||
216 | closeSession m s @ Session {..} = do | ||
217 | notify m s Stopped | ||
218 | send sessionEvents SessionClosed | ||
219 | |||
220 | {----------------------------------------------------------------------- | ||
221 | -- Operations | ||
222 | -----------------------------------------------------------------------} | ||
223 | |||
224 | -- | Normally you need to use 'Control.Monad.Trans.Resource.alloc'. | ||
225 | withSession :: Manager -> InfoHash -> TrackerList () | ||
226 | -> (Session -> IO ()) -> IO () | ||
227 | withSession m ih uris = bracket (newSession ih uris) (closeSession m) | ||
228 | |||
229 | -- | Get last announced status. The only action can alter this status | ||
230 | -- is 'notify'. | ||
231 | getStatus :: Session -> IO Status | ||
232 | getStatus Session {..} = readIORef sessionStatus | ||
233 | |||
234 | getSessionState :: Session -> IO [[TierEntry TrackerSession]] | ||
235 | getSessionState Session {..} = TL.toList <$> readMVar sessionTrackers | ||
236 | |||
237 | -- | Do we need to sent this event to a first working tracker or to | ||
238 | -- the all known good trackers? | ||
239 | allNotify :: AnnounceEvent -> Bool | ||
240 | allNotify Started = False | ||
241 | allNotify Stopped = True | ||
242 | allNotify Completed = True | ||
243 | |||
244 | notifyAll :: Manager -> Session -> AnnounceEvent -> IO () | ||
245 | notifyAll mgr s @ Session {..} event = do | ||
246 | modifyMVar_ sessionTrackers $ | ||
247 | (traversal (notifyTo mgr s event)) | ||
248 | where | ||
249 | traversal | ||
250 | | allNotify event = traverseAll | ||
251 | | otherwise = traverseTiers | ||
252 | |||
253 | -- TODO send notifications to tracker periodically. | ||
254 | -- | | ||
255 | -- | ||
256 | -- This function /may/ block until tracker query proceed. | ||
257 | notify :: Manager -> Session -> AnnounceEvent -> IO () | ||
258 | notify mgr ses event = do | ||
259 | prevStatus <- atomicModifyIORef (sessionStatus ses) $ \ s -> | ||
260 | (fromMaybe s (nextStatus event), s) | ||
261 | when (needNotify event (Just prevStatus) == Just True) $ do | ||
262 | notifyAll mgr ses event | ||
263 | |||
264 | -- TODO run announce if sesion have no peers | ||
265 | -- | The returned list of peers can have duplicates. | ||
266 | -- This function /may/ block. Use async if needed. | ||
267 | askPeers :: Manager -> Session -> IO [PeerAddr IP] | ||
268 | askPeers _mgr ses = do | ||
269 | list <- readMVar (sessionTrackers ses) | ||
270 | L.concat <$> collect (tryTakeData . trackerPeers) list | ||
271 | |||
272 | collect :: (a -> IO (Maybe b)) -> TrackerList a -> IO [b] | ||
273 | collect f lst = (catMaybes . F.toList) <$> traverse f lst | ||
274 | |||
275 | --sourcePeers :: Session -> Source (PeerAddr IP) | ||
276 | --sourcePeers | ||
277 | |||
278 | {----------------------------------------------------------------------- | ||
279 | -- Tracker exchange | ||
280 | -----------------------------------------------------------------------} | ||
281 | |||
282 | -- Trackers discovered through this protocol SHOULD be treated with a | ||
283 | -- certain amount of suspicion. Since the source of a tracker exchange | ||
284 | -- message cannot be trusted, an implementation SHOULD have a lower | ||
285 | -- number of retries before giving up entirely. | ||
286 | |||
287 | addTracker :: Session -> URI -> IO () | ||
288 | addTracker Session {..} uri = do | ||
289 | undefined | ||
290 | send sessionEvents (TrackerAdded uri) | ||
291 | |||
292 | removeTracker :: Manager -> Session -> URI -> IO () | ||
293 | removeTracker m Session {..} uri = do | ||
294 | send sessionEvents (TrackerRemoved uri) | ||
295 | |||
296 | -- Also, as specified under the definitions section, a tracker that | ||
297 | -- has not worked should never be propagated to other peers over the | ||
298 | -- tracker exchange protocol. | ||
299 | |||
300 | -- | Return all known trackers. | ||
301 | getTrackers :: Session -> IO [URI] | ||
302 | getTrackers = undefined | ||
303 | |||
304 | -- | Return trackers from torrent file and | ||
305 | getTrustedTrackers :: Session -> IO [URI] | ||
306 | getTrustedTrackers = undefined | ||