-
Notifications
You must be signed in to change notification settings - Fork 0
/
Tracker.hs
234 lines (206 loc) · 7.93 KB
/
Tracker.hs
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
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
module Tracker where
import Control.Exception
import Control.Monad.EmbedIO
--import Data.Binary.Strict.Get
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy.Char8 as BC8
import qualified Data.Map as M
import Data.Maybe
import Data.Serialize.Get
import Data.Serialize.Builder as CB hiding (append)
import Data.String.Class as S
import Data.Word
import Data.Monoid
import Network.HTTP hiding (Response) -- HTTP doesn't support IPv6; using only urlencode from it
--import Network.Curl -- Curl breaks responses at unusual symbols
import Network.Curl.Download
import Network
import Network.Socket hiding (send, recv)
import Network.Socket.ByteString.Lazy
import Numeric
import Prelude as P hiding (log, concat)
import System.Random
import State
import Types
import TorrentFile
import BEncode
import CompactEncoding
data RPeer = RPeer {
id :: Maybe PeerID,
address :: Address
} deriving Show
data Response = Response {
interval :: Word32,
minInterval :: Word32, -- defaults to interval
-- complete
-- downloaded
-- incomplete
peers :: [RPeer]
} deriving Show
listenPort = 6881
pokeTrackers :: Torrent -> NPT ()
pokeTrackers torrent = do
s <- ask
let tf = torrentFile torrent
urt <- liftIO $ atomically $ readTVar $ useRetracker s
let tracks = if urt then "retracker.local" : trackers tf else trackers tf
--let ht = httpTrackers $ trackers tf
--mapM_ (forkE . pokeTracker torrent) $ trackers tf
mapM_ (handleE (\(e :: SomeException) -> log $ show e) . pokeTracker torrent) tracks
pokeTracker :: Torrent -> ByteString -> NPT ()
pokeTracker t tr = do
log $ append "Poking tracker: " tr
resp <- pokeTracker_ t tr
log $ append "Response: " $ show resp
pokeTracker_ t tr | B.isPrefixOf "http://" tr = pokeHTTPTracker t tr
pokeTracker_ t tr | B.isPrefixOf "udp://" tr = pokeUDPTracker t tr
pokeTracker_ _ _ = return Nothing
--httpTrackers :: [ByteString] -> [ByteString]
--httpTrackers l = filter (B.isPrefixOf "http://") l
--
--udpTrackers :: [ByteString] -> [ByteString]
--udpTrackers l = filter (B.isPrefixOf "udp://") l
{-
Time outs
UDP is an 'unreliable' protocol. This means it doesn't retransmit lost packets itself. The application is responsible for this. If a response is not received after 15 * 2 ^ n seconds, the client should retransmit the request, where n starts at 0 and is increased up to 8 (3840 seconds) after every retransmission. Note that it is necessary to rerequest a connection ID when it has expired.
-}
type TransactionID = Word32
type ConnectionID = Word64
data Event = ENone | ECompleted | EStarted | EStopped
data TUDPQuery = QConnect TransactionID | QAnnounce ConnectionID TransactionID InfoHash PeerID Word64 Word64 Word64 Event (Maybe HostAddress) Word32 Word32 PortNumber
data TUDPResponse = RConnect TransactionID ConnectionID
| RAnnounce {
ratid :: TransactionID,
rainterval :: Word32,
raleechers :: Word32,
raseeders :: Word32,
rapeers :: [Address]
} deriving Show
putEv ENone = putWord32be 0
putEv ECompleted = putWord32be 1
putEv EStarted = putWord32be 2
putEv EStopped = putWord32be 3
putTUDPQuery :: TUDPQuery -> Builder
putTUDPQuery (QConnect tid) = mconcat [
putWord64be 0x41727101980,
putWord32be 0,
putWord32be tid]
putTUDPQuery (QAnnounce cid tid ih pid down left up ev addr key want port) = mconcat [
putWord64be cid,
putWord32be 1,
putWord32be tid,
CB.fromLazyByteString ih,
CB.fromLazyByteString pid,
putWord64be down,
putWord64be left,
putWord64be up,
putEv ev,
putIP4 $ fromMaybe 0 addr,
putWord32be key,
putWord32be want,
putPort port]
getTUDPResponse :: Get TUDPResponse
getTUDPResponse = do
action <- getWord32be
case action of
0 -> do
tid <- getWord32be
cid <- getWord64be
return $ RConnect tid cid
1 -> do
tid <- getWord32be
interval <- getWord32be
leechers <- getWord32be
seeders <- getWord32be
rem <- remaining
peers <- sequence $ replicate (rem `div` 6) $ getCompactPeer4
return $ RAnnounce tid interval leechers seeders peers
pokeUDPTracker :: Torrent -> ByteString -> NPT (Maybe Response)
pokeUDPTracker torrent t_ = do
s <- ask
let peerid = peerID s
let tf = torrentFile torrent
lp <- liftIO $ atomically $ readTVar $ listeningPort s
-- presume we got "udp://tracker.publicbt.com:80" format
let (host, port_) = BC8.break (== ':') $ S.drop 6 t_
let port = toEnum $ (read $ P.tail $ toString port_ :: Int) :: PortNumber
sock <- liftIO $ socket AF_INET Datagram 0
--ha <- liftIO $ inet_addr "127.0.0.1"
(AddrInfo { addrAddress = SockAddrInet _ addr }):_ <- liftIO $ getAddrInfo (Just $ AddrInfo [] AF_INET Datagram defaultProtocol undefined Nothing) (Just $ toString host) Nothing
liftIO $ connect sock $ SockAddrInet port addr
let say = liftIO . send sock . CB.toLazyByteString . putTUDPQuery
let hear = liftIO $ liftM ((\(Right nya) -> nya) . runGetLazy getTUDPResponse) $ recv sock 9000
t1id <- liftIO randomIO
say $ QConnect t1id
RConnect t1id_ cid <- hear
when (t1id /= t1id_) $ fail "FIXME got some other transaction ID"
t2id <- liftIO randomIO
say $ QAnnounce cid t2id (infoHash tf) peerid 0 0 0 ENone Nothing 0 (-1) lp
ra <- hear
when (t2id /= ratid ra) $ fail "FIXME got some other transaction ID"
return $ Just $ Response (rainterval ra) (rainterval ra) $ map (RPeer Nothing) $ rapeers ra
pokeHTTPTracker :: Torrent -> ByteString -> NPT (Maybe Response)
pokeHTTPTracker torrent t_ = do
s <- ask
let peerid = peerID s
-- Got through http://extratorrent.com/article/71/public+open+torrent+trackers.html
let t = BC8.unpack t_
--let t = "http://tracker.istole.it:80/announce"
--let t = "http://bittrk.appspot.com/announce" -- violates bencoding standard
--let t = "http://tracker.torrentbox.com:2710/announce" -- requires auth
--let t = "http://www.h33t.com:3310/announce" -- returns packed peers list
--let t = "http://tracker.openbittorrent.kg:2710/announce" -- requires auth
--let t = "http://tracker.torrent.to:2710/announce" -- returns packed peers list
--let t = "http://tracker.torrentbox.com:2710/announce" -- requires auth
let tf = torrentFile torrent
let vars :: String = urlEncodeVars [
("info_hash", BC8.unpack $ infoHash tf),
("peer_id", BC8.unpack $ peerid),
("port", show listenPort),
("uploaded", "0"),
("downloaded", "0"),
("left", "1")]
let r = concat [t, "?", vars]
log $ show $ r
--resp <- simpleHTTP $ getRequest r
--rb <- getResponseBody resp
--(_, rb) <- curlGetString r []
rb_ <- liftIO $ openURI r
case rb_ of
Left e -> log $ show e
_ -> return ()
let Right rb = rb_
log $ append "Answer from HTTP: " rb
-- "d8:completei1e10:downloadedi0e10:incompletei1e8:intervali1904e12:min intervali952e5:peers12:]P\202[\SUB\225_\142\172\198\SUB\re"
let resp = decodeResponse $ B.fromChunks $ rb : []
case resp of
Left e -> do
log $ show e
return Nothing
Right r -> do
liftIO $ print r
return $ Just r
decodeResponse :: ByteString -> Either ByteString Response
decodeResponse b = let md = bRead b
d = bDict $ fromJust md
fail = M.lookup "failure reason" d in
if isNothing md
then Left "can't decode bencoded tracker answer"
else if isJust fail
then Left $ bString $ fromJust fail
else Right Response {
interval = fromIntegral $ bInt $ fromJust $ M.lookup "interval" d,
minInterval = maybe 0 (fromIntegral . bInt) $ M.lookup "min interval" d,
peers = parsePeers_ d }
parsePeers_ :: M.Map String BEncode -> [RPeer]
parsePeers_ d = let mp4 = M.lookup "peers" d
mp6 = M.lookup "peers6" d in
maybe [] (parsePeers) mp4 ++ maybe [] (parsePeers6) mp6
parsePeers :: BEncode -> [RPeer]
parsePeers (BDict d) = error "Traditional peer lists are unsupported. Send me an example of one plzkthx."
parsePeers (BString d) = map (RPeer Nothing) $ getList d getCompactPeer4
parsePeers6 :: BEncode -> [RPeer]
parsePeers6 (BDict d) = error "Traditional peer lists are unsupported for IPv6. Send me an example of one plzkthx."
parsePeers6 (BString d) = map (RPeer Nothing) $ getList d getCompactPeer6