diff options
-rw-r--r-- | src/Network/BitTorrent/Tracker.hs | 14 | ||||
-rw-r--r-- | src/Network/BitTorrent/Tracker/Protocol.hs | 49 |
2 files changed, 31 insertions, 32 deletions
diff --git a/src/Network/BitTorrent/Tracker.hs b/src/Network/BitTorrent/Tracker.hs index 25d2c358..7a43fb23 100644 --- a/src/Network/BitTorrent/Tracker.hs +++ b/src/Network/BitTorrent/Tracker.hs | |||
@@ -88,8 +88,8 @@ tconnection t = TConnection (tAnnounce t) (tInfoHash t) | |||
88 | 88 | ||
89 | 89 | ||
90 | -- | used to avoid boilerplate; do NOT export me | 90 | -- | used to avoid boilerplate; do NOT export me |
91 | genericReq :: TConnection -> Progress -> TRequest | 91 | genericReq :: TConnection -> Progress -> AnnounceQuery |
92 | genericReq ses pr = TRequest { | 92 | genericReq ses pr = AnnounceQuery { |
93 | reqInfoHash = tconnInfoHash ses | 93 | reqInfoHash = tconnInfoHash ses |
94 | , reqPeerId = tconnPeerId ses | 94 | , reqPeerId = tconnPeerId ses |
95 | , reqPort = tconnPort ses | 95 | , reqPort = tconnPort ses |
@@ -107,7 +107,7 @@ genericReq ses pr = TRequest { | |||
107 | -- | The first request to the tracker that should be created is | 107 | -- | The first request to the tracker that should be created is |
108 | -- 'startedReq'. It includes necessary 'Started' event field. | 108 | -- 'startedReq'. It includes necessary 'Started' event field. |
109 | -- | 109 | -- |
110 | startedReq :: TConnection -> Progress -> TRequest | 110 | startedReq :: TConnection -> Progress -> AnnounceQuery |
111 | startedReq ses pr = (genericReq ses pr) { | 111 | startedReq ses pr = (genericReq ses pr) { |
112 | reqIP = Nothing | 112 | reqIP = Nothing |
113 | , reqNumWant = Just defaultNumWant | 113 | , reqNumWant = Just defaultNumWant |
@@ -118,7 +118,7 @@ startedReq ses pr = (genericReq ses pr) { | |||
118 | -- notify tracker about current state of the client | 118 | -- notify tracker about current state of the client |
119 | -- so new peers could connect to the client. | 119 | -- so new peers could connect to the client. |
120 | -- | 120 | -- |
121 | regularReq :: Int -> TConnection -> Progress -> TRequest | 121 | regularReq :: Int -> TConnection -> Progress -> AnnounceQuery |
122 | regularReq numWant ses pr = (genericReq ses pr) { | 122 | regularReq numWant ses pr = (genericReq ses pr) { |
123 | reqIP = Nothing | 123 | reqIP = Nothing |
124 | , reqNumWant = Just numWant | 124 | , reqNumWant = Just numWant |
@@ -128,7 +128,7 @@ regularReq numWant ses pr = (genericReq ses pr) { | |||
128 | -- | Must be sent to the tracker if the client is shutting down | 128 | -- | Must be sent to the tracker if the client is shutting down |
129 | -- gracefully. | 129 | -- gracefully. |
130 | -- | 130 | -- |
131 | stoppedReq :: TConnection -> Progress -> TRequest | 131 | stoppedReq :: TConnection -> Progress -> AnnounceQuery |
132 | stoppedReq ses pr = (genericReq ses pr) { | 132 | stoppedReq ses pr = (genericReq ses pr) { |
133 | reqIP = Nothing | 133 | reqIP = Nothing |
134 | , reqNumWant = Nothing | 134 | , reqNumWant = Nothing |
@@ -139,7 +139,7 @@ stoppedReq ses pr = (genericReq ses pr) { | |||
139 | -- However, must not be sent if the download was already 100% | 139 | -- However, must not be sent if the download was already 100% |
140 | -- complete. | 140 | -- complete. |
141 | -- | 141 | -- |
142 | completedReq :: TConnection -> Progress -> TRequest | 142 | completedReq :: TConnection -> Progress -> AnnounceQuery |
143 | completedReq ses pr = (genericReq ses pr) { | 143 | completedReq ses pr = (genericReq ses pr) { |
144 | reqIP = Nothing | 144 | reqIP = Nothing |
145 | , reqNumWant = Nothing | 145 | , reqNumWant = Nothing |
@@ -233,7 +233,7 @@ withTracker initProgress conn action = bracket start end (action . fst) | |||
233 | resp <- tryJust isIOException $ do | 233 | resp <- tryJust isIOException $ do |
234 | askTracker (tconnAnnounce conn) (regularReq defaultNumWant conn pr) | 234 | askTracker (tconnAnnounce conn) (regularReq defaultNumWant conn pr) |
235 | case resp of | 235 | case resp of |
236 | Right (OK {..}) -> do | 236 | Right (AnnounceInfo {..}) -> do |
237 | writeIORef seInterval respInterval | 237 | writeIORef seInterval respInterval |
238 | 238 | ||
239 | -- we rely on the fact that union on lists is not | 239 | -- we rely on the fact that union on lists is not |
diff --git a/src/Network/BitTorrent/Tracker/Protocol.hs b/src/Network/BitTorrent/Tracker/Protocol.hs index e844f8b8..95d82b36 100644 --- a/src/Network/BitTorrent/Tracker/Protocol.hs +++ b/src/Network/BitTorrent/Tracker/Protocol.hs | |||
@@ -22,9 +22,8 @@ | |||
22 | {-# LANGUAGE RecordWildCards #-} | 22 | {-# LANGUAGE RecordWildCards #-} |
23 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | 23 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} |
24 | {-# LANGUAGE FlexibleInstances #-} | 24 | {-# LANGUAGE FlexibleInstances #-} |
25 | -- TODO: add "compact" field to TRequest | ||
26 | module Network.BitTorrent.Tracker.Protocol | 25 | module Network.BitTorrent.Tracker.Protocol |
27 | ( Event(..), TRequest(..), TResponse(..) | 26 | ( Event(..), AnnounceQuery(..), AnnounceInfo(..) |
28 | , askTracker, leaveTracker | 27 | , askTracker, leaveTracker |
29 | 28 | ||
30 | -- * Defaults | 29 | -- * Defaults |
@@ -55,7 +54,7 @@ import Network.URI | |||
55 | import Network.BitTorrent.Peer | 54 | import Network.BitTorrent.Peer |
56 | 55 | ||
57 | {----------------------------------------------------------------------- | 56 | {----------------------------------------------------------------------- |
58 | Tracker messages | 57 | Tracker Announce |
59 | -----------------------------------------------------------------------} | 58 | -----------------------------------------------------------------------} |
60 | 59 | ||
61 | -- | Events used to specify which kind of tracker request is performed. | 60 | -- | Events used to specify which kind of tracker request is performed. |
@@ -73,7 +72,7 @@ data Event = Started | |||
73 | -- the torrent. The most important, requests are used by the tracker | 72 | -- the torrent. The most important, requests are used by the tracker |
74 | -- to keep track lists of active peer for a particular torrent. | 73 | -- to keep track lists of active peer for a particular torrent. |
75 | -- | 74 | -- |
76 | data TRequest = TRequest { -- TODO peer here | 75 | data AnnounceQuery = AnnounceQuery { |
77 | reqInfoHash :: !InfoHash | 76 | reqInfoHash :: !InfoHash |
78 | -- ^ Hash of info part of the torrent usually obtained from | 77 | -- ^ Hash of info part of the torrent usually obtained from |
79 | -- 'Torrent'. | 78 | -- 'Torrent'. |
@@ -112,9 +111,9 @@ data TRequest = TRequest { -- TODO peer here | |||
112 | -- participate in the torrent. The most important is 'respPeer' list | 111 | -- participate in the torrent. The most important is 'respPeer' list |
113 | -- used to join the swarm. | 112 | -- used to join the swarm. |
114 | -- | 113 | -- |
115 | data TResponse = | 114 | data AnnounceInfo = |
116 | Failure Text -- ^ Failure reason in human readable form. | 115 | Failure Text -- ^ Failure reason in human readable form. |
117 | | OK { -- TODO rename to anounce | 116 | | AnnounceInfo { |
118 | respWarning :: Maybe Text | 117 | respWarning :: Maybe Text |
119 | -- ^ Human readable warning. | 118 | -- ^ Human readable warning. |
120 | 119 | ||
@@ -138,12 +137,12 @@ data TResponse = | |||
138 | } deriving Show | 137 | } deriving Show |
139 | 138 | ||
140 | {----------------------------------------------------------------------- | 139 | {----------------------------------------------------------------------- |
141 | HTTP Tracker encoding | 140 | HTTP Announce |
142 | -----------------------------------------------------------------------} | 141 | -----------------------------------------------------------------------} |
143 | 142 | ||
144 | instance BEncodable TResponse where | 143 | instance BEncodable AnnounceInfo where |
145 | toBEncode (Failure t) = fromAssocs ["failure reason" --> t] | 144 | toBEncode (Failure t) = fromAssocs ["failure reason" --> t] |
146 | toBEncode (OK {..}) = fromAssocs | 145 | toBEncode AnnounceInfo {..} = fromAssocs |
147 | [ "interval" --> respInterval | 146 | [ "interval" --> respInterval |
148 | , "min interval" -->? respMinInterval | 147 | , "min interval" -->? respMinInterval |
149 | , "complete" -->? respComplete | 148 | , "complete" -->? respComplete |
@@ -153,7 +152,8 @@ instance BEncodable TResponse where | |||
153 | 152 | ||
154 | fromBEncode (BDict d) | 153 | fromBEncode (BDict d) |
155 | | Just t <- M.lookup "failure reason" d = Failure <$> fromBEncode t | 154 | | Just t <- M.lookup "failure reason" d = Failure <$> fromBEncode t |
156 | | otherwise = OK <$> d >--? "warning message" | 155 | | otherwise = AnnounceInfo |
156 | <$> d >--? "warning message" | ||
157 | <*> d >-- "interval" | 157 | <*> d >-- "interval" |
158 | <*> d >--? "min interval" | 158 | <*> d >--? "min interval" |
159 | <*> d >--? "complete" | 159 | <*> d >--? "complete" |
@@ -165,7 +165,7 @@ instance BEncodable TResponse where | |||
165 | getPeers (Just (BString s)) = runGet getCompactPeerList s | 165 | getPeers (Just (BString s)) = runGet getCompactPeerList s |
166 | getPeers _ = decodingError "Peers" | 166 | getPeers _ = decodingError "Peers" |
167 | 167 | ||
168 | fromBEncode _ = decodingError "TResponse" | 168 | fromBEncode _ = decodingError "AnnounceInfo" |
169 | 169 | ||
170 | instance URLShow PortNumber where | 170 | instance URLShow PortNumber where |
171 | urlShow = urlShow . fromEnum | 171 | urlShow = urlShow . fromEnum |
@@ -179,8 +179,8 @@ instance URLShow Event where | |||
179 | -- INVARIANT: this is always nonempty list | 179 | -- INVARIANT: this is always nonempty list |
180 | (x : xs) = show e | 180 | (x : xs) = show e |
181 | 181 | ||
182 | instance URLEncode TRequest where | 182 | instance URLEncode AnnounceQuery where |
183 | urlEncode TRequest {..} = mconcat | 183 | urlEncode AnnounceQuery {..} = mconcat |
184 | [ s "peer_id" %= reqPeerId | 184 | [ s "peer_id" %= reqPeerId |
185 | , s "port" %= reqPort | 185 | , s "port" %= reqPort |
186 | , s "uploaded" %= reqUploaded | 186 | , s "uploaded" %= reqUploaded |
@@ -192,13 +192,13 @@ instance URLEncode TRequest where | |||
192 | ] | 192 | ] |
193 | where s :: String -> String; s = id; {-# INLINE s #-} | 193 | where s :: String -> String; s = id; {-# INLINE s #-} |
194 | 194 | ||
195 | encodeRequest :: URI -> TRequest -> URI | 195 | encodeRequest :: URI -> AnnounceQuery -> URI |
196 | encodeRequest announce req = URL.urlEncode req | 196 | encodeRequest announce req = URL.urlEncode req |
197 | `addToURI` announce | 197 | `addToURI` announce |
198 | `addHashToURI` reqInfoHash req | 198 | `addHashToURI` reqInfoHash req |
199 | 199 | ||
200 | {----------------------------------------------------------------------- | 200 | {----------------------------------------------------------------------- |
201 | UDP tracker encoding | 201 | UDP announce |
202 | -----------------------------------------------------------------------} | 202 | -----------------------------------------------------------------------} |
203 | 203 | ||
204 | type EventId = Word32 | 204 | type EventId = Word32 |
@@ -223,8 +223,8 @@ getEvent = do | |||
223 | 3 -> return $ Just Stopped | 223 | 3 -> return $ Just Stopped |
224 | _ -> fail "unknown event id" | 224 | _ -> fail "unknown event id" |
225 | 225 | ||
226 | instance Serialize TRequest where | 226 | instance Serialize AnnounceQuery where |
227 | put TRequest {..} = do | 227 | put AnnounceQuery {..} = do |
228 | put reqInfoHash | 228 | put reqInfoHash |
229 | put reqPeerId | 229 | put reqPeerId |
230 | 230 | ||
@@ -254,7 +254,7 @@ instance Serialize TRequest where | |||
254 | 254 | ||
255 | port <- get | 255 | port <- get |
256 | 256 | ||
257 | return $ TRequest { | 257 | return $ AnnounceQuery { |
258 | reqInfoHash = ih | 258 | reqInfoHash = ih |
259 | , reqPeerId = pid | 259 | , reqPeerId = pid |
260 | , reqPort = port | 260 | , reqPort = port |
@@ -266,9 +266,9 @@ instance Serialize TRequest where | |||
266 | , reqEvent = ev | 266 | , reqEvent = ev |
267 | } | 267 | } |
268 | 268 | ||
269 | instance Serialize TResponse where | 269 | instance Serialize AnnounceInfo where |
270 | put (Failure msg) = put $ encodeUtf8 msg | 270 | put (Failure msg) = put $ encodeUtf8 msg |
271 | put OK {..} = do | 271 | put AnnounceInfo {..} = do |
272 | putWord32be $ fromIntegral respInterval | 272 | putWord32be $ fromIntegral respInterval |
273 | putWord32be $ fromIntegral $ fromMaybe 0 respIncomplete | 273 | putWord32be $ fromIntegral $ fromMaybe 0 respIncomplete |
274 | putWord32be $ fromIntegral $ fromMaybe 0 respComplete | 274 | putWord32be $ fromIntegral $ fromMaybe 0 respComplete |
@@ -280,7 +280,7 @@ instance Serialize TResponse where | |||
280 | seeders <- getWord32be | 280 | seeders <- getWord32be |
281 | peers <- many get | 281 | peers <- many get |
282 | 282 | ||
283 | return $ OK { | 283 | return $ AnnounceInfo { |
284 | respWarning = Nothing | 284 | respWarning = Nothing |
285 | , respInterval = fromIntegral interval | 285 | , respInterval = fromIntegral interval |
286 | , respMinInterval = Nothing | 286 | , respMinInterval = Nothing |
@@ -289,7 +289,6 @@ instance Serialize TResponse where | |||
289 | , respPeers = peers | 289 | , respPeers = peers |
290 | } | 290 | } |
291 | 291 | ||
292 | |||
293 | {----------------------------------------------------------------------- | 292 | {----------------------------------------------------------------------- |
294 | Tracker | 293 | Tracker |
295 | -----------------------------------------------------------------------} | 294 | -----------------------------------------------------------------------} |
@@ -316,7 +315,7 @@ mkHTTPRequest uri = Request uri GET [] "" | |||
316 | -- announce list. This function throws 'IOException' if it couldn't | 315 | -- announce list. This function throws 'IOException' if it couldn't |
317 | -- send request or receive response or decode response. | 316 | -- send request or receive response or decode response. |
318 | -- | 317 | -- |
319 | askTracker :: URI -> TRequest -> IO TResponse | 318 | askTracker :: URI -> AnnounceQuery -> IO AnnounceInfo |
320 | askTracker announce req = do | 319 | askTracker announce req = do |
321 | let r = mkHTTPRequest (encodeRequest announce req) | 320 | let r = mkHTTPRequest (encodeRequest announce req) |
322 | 321 | ||
@@ -333,7 +332,7 @@ askTracker announce req = do | |||
333 | 332 | ||
334 | -- | The same as the 'askTracker' but ignore response. Used in | 333 | -- | The same as the 'askTracker' but ignore response. Used in |
335 | -- conjunction with 'Stopped'. | 334 | -- conjunction with 'Stopped'. |
336 | leaveTracker :: URI -> TRequest -> IO () | 335 | leaveTracker :: URI -> AnnounceQuery -> IO () |
337 | leaveTracker announce req = do | 336 | leaveTracker announce req = do |
338 | let r = mkHTTPRequest (encodeRequest announce req) | 337 | let r = mkHTTPRequest (encodeRequest announce req) |
339 | void $ simpleHTTP r >>= getResponseBody | 338 | void $ simpleHTTP r >>= getResponseBody |