summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Network/BitTorrent/Tracker.hs14
-rw-r--r--src/Network/BitTorrent/Tracker/Protocol.hs49
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
91genericReq :: TConnection -> Progress -> TRequest 91genericReq :: TConnection -> Progress -> AnnounceQuery
92genericReq ses pr = TRequest { 92genericReq 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--
110startedReq :: TConnection -> Progress -> TRequest 110startedReq :: TConnection -> Progress -> AnnounceQuery
111startedReq ses pr = (genericReq ses pr) { 111startedReq 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--
121regularReq :: Int -> TConnection -> Progress -> TRequest 121regularReq :: Int -> TConnection -> Progress -> AnnounceQuery
122regularReq numWant ses pr = (genericReq ses pr) { 122regularReq 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--
131stoppedReq :: TConnection -> Progress -> TRequest 131stoppedReq :: TConnection -> Progress -> AnnounceQuery
132stoppedReq ses pr = (genericReq ses pr) { 132stoppedReq 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--
142completedReq :: TConnection -> Progress -> TRequest 142completedReq :: TConnection -> Progress -> AnnounceQuery
143completedReq ses pr = (genericReq ses pr) { 143completedReq 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
26module Network.BitTorrent.Tracker.Protocol 25module 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
55import Network.BitTorrent.Peer 54import 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--
76data TRequest = TRequest { -- TODO peer here 75data 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--
115data TResponse = 114data 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
144instance BEncodable TResponse where 143instance 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
170instance URLShow PortNumber where 170instance 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
182instance URLEncode TRequest where 182instance 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
195encodeRequest :: URI -> TRequest -> URI 195encodeRequest :: URI -> AnnounceQuery -> URI
196encodeRequest announce req = URL.urlEncode req 196encodeRequest 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
204type EventId = Word32 204type 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
226instance Serialize TRequest where 226instance 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
269instance Serialize TResponse where 269instance 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--
319askTracker :: URI -> TRequest -> IO TResponse 318askTracker :: URI -> AnnounceQuery -> IO AnnounceInfo
320askTracker announce req = do 319askTracker 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'.
336leaveTracker :: URI -> TRequest -> IO () 335leaveTracker :: URI -> AnnounceQuery -> IO ()
337leaveTracker announce req = do 336leaveTracker 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