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
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
|
-- |
-- Copyright : (c) Sam Truzjan 2014
-- License : BSD
-- Maintainer : pxqr.sta@gmail.com
-- Stability : experimental
-- Portability : portable
--
-- Multitracker sessions.
--
module Network.BitTorrent.Tracker.Session
( -- * Session
Session
, newSession
, closeSession
-- * Events
, Event (..)
, notify
-- * Query
, askPeers
) where
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Data.Default
import Data.Fixed
import Data.Foldable
import Data.List as L
import Data.Maybe
import Data.IORef
import Data.Text as T
import Data.Time
import Data.Traversable
import Network
import Network.URI
import Data.Torrent
import Data.Torrent.InfoHash
import Network.BitTorrent.Core
import Network.BitTorrent.Tracker.Cache
import Network.BitTorrent.Tracker.List
import Network.BitTorrent.Tracker.Message
import Network.BitTorrent.Tracker.RPC as RPC
{-----------------------------------------------------------------------
-- Tracker entry
-----------------------------------------------------------------------}
data Scrape = Scrape
{ leechersCount :: Maybe Int
, seedersCount :: Maybe Int
} deriving (Show, Eq)
instance Default Scrape where
def = Scrape Nothing Nothing
data Status
= Running
| Paused
deriving (Show, Eq)
instance Default Status where
def = Paused
nextStatus :: Maybe Event -> Status
nextStatus Nothing = Running
nextStatus (Just Started ) = Running
nextStatus (Just Stopped ) = Paused
nextStatus (Just Completed) = Running
needNotify :: Maybe Event -> Maybe Status -> Bool
-- we always send _regular_ announce requests (for e.g. to get more peers);
needNotify Nothing _ = True
needNotify (Just Started) Nothing = True
needNotify (Just Stopped) Nothing = False
needNotify (Just Completed) Nothing = False
needNotify Nothing (Just Running) = True
needNotify Nothing (Just Paused ) = True
-- | Do we need to sent this event to a first working tracker or to
-- the all known good trackers?
allNotify :: Maybe Event -> Bool
allNotify Nothing = False
allNotify (Just Started) = False
allNotify (Just Stopped) = True
allNotify (Just Completed) = True
-- | Single tracker session.
data TrackerEntry = TrackerEntry
{ -- | Tracker announce URI.
trackerURI :: !URI
-- | Used to notify 'Stopped' and 'Completed' events.
, statusSent :: !(Maybe Status)
-- |
, peersCache :: Cached [PeerAddr IP]
-- | May be used to show brief swarm stats in client GUI.
, scrapeCache :: Cached Scrape
}
nullEntry :: URI -> TrackerEntry
nullEntry uri = TrackerEntry uri Nothing def def
{-----------------------------------------------------------------------
-- Multitracker Session
-----------------------------------------------------------------------}
-- | Multitracker session.
data Session = Session
{ infohash :: !InfoHash
, currentStatus :: !(MVar Status)
, trackers :: !(MVar (TrackerList TrackerEntry))
}
-- Just Started
newSession :: InfoHash -> TrackerList URI -> IO Session
newSession ih origUris = do
uris <- shuffleTiers origUris
status <- newMVar def
entries <- newMVar (fmap nullEntry uris)
return (Session ih status entries)
-- Just Stopped
closeSession :: Session -> IO ()
closeSession _ = return ()
seconds :: Int -> NominalDiffTime
seconds n = realToFrac (toEnum n :: Uni)
cachePeers :: AnnounceInfo -> IO (Cached [PeerAddr IP])
cachePeers AnnounceInfo {..} =
newCached (seconds respInterval)
(seconds (fromMaybe respInterval respMinInterval))
(getPeerList respPeers)
cacheScrape :: AnnounceInfo -> IO (Cached Scrape)
cacheScrape AnnounceInfo {..} =
newCached (seconds respInterval)
(seconds (fromMaybe respInterval respMinInterval))
Scrape
{ seedersCount = respComplete
, leechersCount = respIncomplete
}
announceAll :: Manager -> Session -> Maybe Event -> IO ()
announceAll mgr Session {..} mevent = do
modifyMVar_ trackers (traversal announceTo)
where
traversal
| allNotify mevent = traverseAll
| otherwise = traverseTiers
announceTo entry @ TrackerEntry {..}
| mevent `needNotify` statusSent = do
let q = SAnnounceQuery infohash def Nothing mevent
res <- RPC.announce mgr trackerURI q
TrackerEntry trackerURI (Just (nextStatus mevent))
<$> cachePeers res <*> cacheScrape res
| otherwise = return entry
-- TODO send notifications to tracker periodically.
-- |
--
-- This function /may/ block until tracker query proceed.
notify :: Manager -> Session -> Event -> IO ()
notify mgr ses event = announceAll mgr ses (Just event)
-- TODO fork thread for reannounces
-- |
announce :: Manager -> Session -> IO ()
announce mgr ses = announceAll mgr ses Nothing
-- TODO run announce if sesion have no peers
-- | This function /may/ block. Use async if needed.
askPeers :: Manager -> Session -> IO [PeerAddr IP]
askPeers mgr ses = do
list <- readMVar (trackers ses)
L.concat <$> collect (tryTakeData . peersCache) list
collect :: (a -> IO (Maybe b)) -> TrackerList a -> IO [b]
collect f lst =(catMaybes . toList) <$> traverse f lst
--sourcePeers :: Session -> Source (PeerAddr IP)
--sourcePeers
{-----------------------------------------------------------------------
-- State query
-----------------------------------------------------------------------}
data TrackerInfo = TrackerInfo
{
}
--instance ToJSON TrackerInfo where
-- toJSON = undefined
-- |
--getSessionState :: Session -> IO (TrackerList TrackerInfo)
--getSessionState = undefined
|
