1 {-# LANGUAGE OverloadedStrings #-}
2 module FuncTorrent.Tracker
9 import Prelude hiding (lookup, splitAt)
12 import Control.Applicative (liftA2)
13 import Control.Concurrent (threadDelay)
14 import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, readMVar, putMVar)
15 import Data.Binary (Binary(..), encode, decode)
16 import Data.Binary.Put (putWord16be, putWord32be, putWord64be, putByteString)
17 import Data.Binary.Get (Get, isEmpty, getByteString, getWord16be, getWord32be)
18 import Data.ByteString (ByteString, hGet, hPut)
19 import Data.ByteString.Char8 as BC (pack, unpack, splitAt)
20 import Data.ByteString.Lazy (fromStrict, toStrict)
21 import Data.Char (chr)
22 import Data.List (intercalate, isPrefixOf)
23 import Data.Map as M (lookup)
24 import Network (connectTo, PortID(..), PortNumber, Socket)
25 import Network.Socket (defaultProtocol, SocketType( Datagram ), Family( AF_INET ), SockAddr( SockAddrInet ), inet_addr, socket)
26 import Network.Socket.ByteString (sendTo, recv)
27 import Network.HTTP.Base (urlEncode)
28 import qualified Data.ByteString.Base16 as B16 (encode)
30 import FuncTorrent.Bencode (BVal(..))
31 import qualified FuncTorrent.Bencode as Benc
32 import FuncTorrent.Metainfo (Info(..), Metainfo(..))
33 import FuncTorrent.Network (sendGetRequest)
34 import FuncTorrent.Peer (Peer(..))
35 import FuncTorrent.Utils (splitN)
37 data TrackerProtocol = Http
43 data TrackerResponse = TrackerResponse {
46 , complete :: Maybe Integer
47 , incomplete :: Maybe Integer
50 data TrackerEventState = None
56 data TState = TState {
57 uploaded :: MVar Integer
58 , downloaded :: MVar Integer
60 , currentState :: TrackerEventState
61 , connectedPeers :: MVar [Peer]
64 -- UDP tracker: http://bittorrent.org/beps/bep_0015.html
73 data UDPRequest = ConnectReq Integer
74 | AnnounceReq Integer Integer ByteString String Integer Integer Integer TrackerEventState Integer
75 | ScrapeReq Integer Integer ByteString
78 data UDPResponse = ConnectResp Integer Integer -- transaction_id connection_id
79 | AnnounceResp Integer Integer Integer Integer [(IP, Port)] -- transaction_id interval leechers seeders [(ip, port)]
80 | ScrapeResp Integer Integer Integer Integer
81 | ErrorResp Integer String
84 actionToInteger :: Action -> Integer
85 actionToInteger Connect = 0
86 actionToInteger Announce = 1
87 actionToInteger Scrape = 2
89 intToAction :: Integer -> Action
90 intToAction 0 = Connect
91 intToAction 1 = Announce
92 intToAction 2 = Scrape
94 eventToInteger :: TrackerEventState -> Integer
95 eventToInteger None = 0
96 eventToInteger Completed = 1
97 eventToInteger Started = 2
98 eventToInteger Stopped = 3
100 instance Binary UDPRequest where
101 put (ConnectReq transId) = do
102 putWord64be 0x41727101980
103 putWord32be $ fromIntegral (actionToInteger Connect)
104 putWord32be (fromIntegral transId)
105 put (AnnounceReq connId transId infohash peerId down left up event port) = do
106 putWord64be $ fromIntegral connId
107 putWord32be $ fromIntegral (actionToInteger Announce)
108 putWord32be $ fromIntegral transId
109 putByteString infohash
110 putByteString (BC.pack peerId)
111 putWord64be (fromIntegral down)
112 putWord64be (fromIntegral left)
113 putWord64be (fromIntegral up)
114 putWord32be $ fromIntegral (eventToInteger None)
116 -- key is optional, we will not send it for now
117 putWord32be $ fromIntegral (-1)
118 putWord16be $ fromIntegral port
119 put (ScrapeReq _ _ _) = undefined
122 instance Binary UDPResponse where
125 a <- getWord32be -- action
127 0 -> liftA2 ConnectResp (fromIntegral <$> getWord32be) (fromIntegral <$> getWord32be)
129 tid <- fromIntegral <$> getWord32be
130 interval' <- fromIntegral <$> getWord32be
131 _ <- getWord32be -- leechers
132 _ <- getWord32be -- seeders
133 ipportpairs <- getIPPortPairs -- [(ip, port)]
134 return $ AnnounceResp tid interval' 0 0 ipportpairs
136 tid <- fromIntegral <$> getWord32be
140 return $ ScrapeResp tid 0 0 0
141 3 -> do -- error response
142 tid <- fromIntegral <$> getWord32be
143 bs <- getByteString 4
144 return $ ErrorResp tid $ unpack bs
145 _ -> error ("unknown response action type: " ++ show a)
147 getIPPortPairs :: Get [(IP, Port)]
153 ip <- toIP <$> getByteString 6
154 port <- toPort <$> getByteString 2
155 ipportpairs <- getIPPortPairs
156 return $ (ip, port) : ipportpairs
158 initialTrackerState :: Integer -> IO TState
159 initialTrackerState sz = do
163 return $ TState { currentState = None
164 , connectedPeers = ps
169 -- | Deserialize HTTP tracker response
170 parseTrackerResponse :: BVal -> Either ByteString TrackerResponse
171 parseTrackerResponse resp =
172 case lookup "failure reason" body of
173 Just (Bstr err) -> Left err
174 Just _ -> Left "Unknown failure"
176 let (Just (Bint i)) = lookup "interval" body
177 (Just (Bstr peersBS)) = lookup "peers" body
178 pl = map makePeer (splitN 6 peersBS)
179 in Right TrackerResponse {
183 , incomplete = Nothing
188 toInt :: String -> Integer
191 makePeer :: ByteString -> Peer
192 makePeer peer = Peer "" (toIP ip') (toPort port')
193 where (ip', port') = splitAt 4 peer
195 toPort :: ByteString -> Port
196 toPort = read . ("0x" ++) . unpack . B16.encode
198 toIP :: ByteString -> IP
199 toIP = Data.List.intercalate "." .
200 map (show . toInt . ("0x" ++) . unpack) .
201 splitN 2 . B16.encode
203 --- | URL encode hash as per RFC1738
205 --- REVIEW: Why is this not written in terms of `Network.HTTP.Base.urlEncode` or
206 --- equivalent library function?
207 urlEncodeHash :: ByteString -> String
208 urlEncodeHash bs = concatMap (encode' . unpack) (splitN 2 bs)
209 where encode' b@[c1, c2] = let c = chr (read ("0x" ++ b))
212 escape i c1 c2 | i `elem` nonSpecialChars = [i]
213 | otherwise = "%" ++ [c1] ++ [c2]
215 nonSpecialChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_.~"
217 -- | Make arguments that should be posted to tracker.
218 -- This is a separate pure function for testability.
219 mkArgs :: PortNumber -> String -> Integer -> Integer -> Metainfo -> [(String, ByteString)]
220 mkArgs port peer_id up down m =
221 let fileSize = lengthInBytes $ info m
222 bytesLeft = fileSize - down
224 [("info_hash", pack . urlEncodeHash . B16.encode . infoHash $ m),
225 ("peer_id", pack . urlEncode $ peer_id),
226 ("port", pack $ show port),
227 ("uploaded", pack $ show up),
228 ("downloaded", pack $ show down),
229 ("left", pack $ show bytesLeft),
231 ("event", "started")]
233 trackerLoop :: PortNumber -> String -> Metainfo -> TState -> IO ByteString
234 trackerLoop port peerId m st = do
235 up <- readMVar $ uploaded st
236 down <- readMVar $ downloaded st
237 resp <- sendGetRequest (head . announceList $ m) $ mkArgs port peerId up down m
238 case Benc.decode resp of
239 Left e -> return $ pack (show e)
241 case parseTrackerResponse trackerInfo of
244 _ <- threadDelay $ fromIntegral (interval tresp)
245 _ <- putMVar (connectedPeers st) (peers tresp)
246 trackerLoop port peerId m st
249 getResponse :: Socket -> IO UDPResponse
251 -- connect packet is 16 bytes long
252 -- announce packet is atleast 20 bytes long
253 bs <- recv s (16*1024)
254 return $ decode $ fromStrict bs
256 sendRequest :: Socket -> String -> PortNumber -> UDPRequest -> IO ()
257 sendRequest s ip port req = do
258 hostaddr <- inet_addr ip
259 _ <- sendTo s bsReq $ SockAddrInet (fromIntegral port) hostaddr
261 where bsReq = toStrict $ encode req
263 getTrackerType :: String -> TrackerProtocol
264 getTrackerType url | isPrefixOf "http://" url = Http
265 | isPrefixOf "udp://" url = Udp
266 | otherwise = UnknownProtocol
268 udpTrackerLoop :: PortNumber -> String -> Metainfo -> TState -> IO String
269 udpTrackerLoop port peerId m st = do
270 -- h <- connectTo "exodus.desync.com" (PortNumber 6969)
271 s <- socket AF_INET Datagram defaultProtocol
272 hostAddr <- inet_addr "185.37.101.229"
273 putStrLn "connected to tracker"
274 _ <- sendTo s (toStrict $ encode (ConnectReq 42)) (SockAddrInet 2710 hostAddr)
275 putStrLn "--> sent ConnectReq to tracker"
277 putStrLn "<-- recv ConnectResp from tracker"