1 {-# LANGUAGE OverloadedStrings #-}
2 module FuncTorrent.Tracker
8 import Prelude hiding (lookup, splitAt)
10 import System.IO (Handle)
11 import Control.Applicative (liftA2)
12 import Control.Concurrent (threadDelay)
13 import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, readMVar, putMVar)
14 import Data.Binary (Binary(..), encode, decode)
15 import Data.Binary.Put (putWord16be, putWord32be, putWord64be, putByteString)
16 import Data.Binary.Get (Get, isEmpty, getByteString, getWord16be, getWord32be)
17 import Data.ByteString (ByteString, hGet, hPut)
18 import Data.ByteString.Char8 as BC (pack, unpack, splitAt)
19 import Data.ByteString.Lazy (fromStrict, toStrict)
20 import Data.Char (chr)
21 import Data.List (intercalate, isPrefixOf)
22 import Data.Map as M (lookup)
23 import Network (PortNumber)
24 import Network.HTTP.Base (urlEncode)
25 import qualified Data.ByteString.Base16 as B16 (encode)
27 import FuncTorrent.Bencode (BVal(..))
28 import qualified FuncTorrent.Bencode as Benc
29 import FuncTorrent.Metainfo (Info(..), Metainfo(..))
30 import FuncTorrent.Network (sendGetRequest)
31 import FuncTorrent.Peer (Peer(..))
32 import FuncTorrent.Utils (splitN)
35 data TrackerProtocol = Http
41 data TrackerResponse = TrackerResponse {
44 , complete :: Maybe Integer
45 , incomplete :: Maybe Integer
48 data TrackerEventState = None
54 data TState = TState {
55 uploaded :: MVar Integer
56 , downloaded :: MVar Integer
58 , currentState :: TrackerEventState
59 , connectedPeers :: MVar [Peer]
62 -- UDP tracker: http://bittorrent.org/beps/bep_0015.html
71 data UDPRequest = ConnectReq Integer
72 | AnnounceReq Integer Integer ByteString String Integer Integer Integer TrackerEventState Integer
73 | ScrapeReq Integer Integer ByteString
76 data UDPResponse = ConnectResp Integer Integer -- transaction_id connection_id
77 | AnnounceResp Integer Integer Integer Integer [(IP, Port)] -- transaction_id interval leechers seeders [(ip, port)]
78 | ScrapeResp Integer Integer Integer Integer
81 actionToInteger :: Action -> Integer
82 actionToInteger Connect = 0
83 actionToInteger Announce = 1
84 actionToInteger Scrape = 2
86 intToAction :: Integer -> Action
87 intToAction 0 = Connect
88 intToAction 1 = Announce
89 intToAction 2 = Scrape
91 eventToInteger :: TrackerEventState -> Integer
92 eventToInteger None = 0
93 eventToInteger Completed = 1
94 eventToInteger Started = 2
95 eventToInteger Stopped = 3
97 instance Binary UDPRequest where
98 put (ConnectReq transId) = do
99 putWord64be 0x41727101980
100 putWord32be $ fromIntegral (actionToInteger Connect)
101 putWord32be (fromIntegral transId)
102 put (AnnounceReq connId transId infohash peerId down left up event port) = do
103 putWord64be $ fromIntegral connId
104 putWord32be $ fromIntegral (actionToInteger Announce)
105 putWord32be $ fromIntegral transId
106 putByteString infohash
107 putByteString (BC.pack peerId)
108 putWord64be (fromIntegral down)
109 putWord64be (fromIntegral left)
110 putWord64be (fromIntegral up)
111 putWord32be $ fromIntegral (eventToInteger None)
113 -- key is optional, we will not send it for now
114 putWord32be $ fromIntegral (-1)
115 putWord16be $ fromIntegral port
116 put (ScrapeReq _ _ _) = undefined
119 instance Binary UDPResponse where
122 a <- getWord32be -- action
124 0 -> liftA2 ConnectResp (fromIntegral <$> getWord32be) (fromIntegral <$> getWord32be)
126 tid <- fromIntegral <$> getWord32be
127 interval' <- fromIntegral <$> getWord32be
128 _ <- getWord32be -- leechers
129 _ <- getWord32be -- seeders
130 ipportpairs <- getIPPortPairs -- [(ip, port)]
131 return $ AnnounceResp tid interval' 0 0 ipportpairs
133 tid <- fromIntegral <$> getWord32be
137 return $ ScrapeResp tid 0 0 0
138 _ -> error ("unknown response action type: " ++ show a)
140 getIPPortPairs :: Get [(IP, Port)]
146 ip <- toIP <$> getByteString 6
147 port <- toPort <$> getByteString 2
148 ipportpairs <- getIPPortPairs
149 return $ (ip, port) : ipportpairs
151 initialTrackerState :: Integer -> IO TState
152 initialTrackerState sz = do
156 return $ TState { currentState = None
157 , connectedPeers = ps
162 -- | Deserialize tracker response
163 mkTrackerResponse :: BVal -> Either ByteString TrackerResponse
164 mkTrackerResponse resp =
165 case lookup "failure reason" body of
166 Just (Bstr err) -> Left err
167 Just _ -> Left "Unknown failure"
169 let (Just (Bint i)) = lookup "interval" body
170 (Just (Bstr peersBS)) = lookup "peers" body
171 pl = map makePeer (splitN 6 peersBS)
172 in Right TrackerResponse {
176 , incomplete = Nothing
181 toInt :: String -> Integer
184 makePeer :: ByteString -> Peer
185 makePeer peer = Peer "" (toIP ip') (toPort port')
186 where (ip', port') = splitAt 4 peer
188 toPort :: ByteString -> Port
189 toPort = read . ("0x" ++) . unpack . B16.encode
191 toIP :: ByteString -> IP
192 toIP = Data.List.intercalate "." .
193 map (show . toInt . ("0x" ++) . unpack) .
194 splitN 2 . B16.encode
196 --- | URL encode hash as per RFC1738
198 --- REVIEW: Why is this not written in terms of `Network.HTTP.Base.urlEncode` or
199 --- equivalent library function?
200 urlEncodeHash :: ByteString -> String
201 urlEncodeHash bs = concatMap (encode' . unpack) (splitN 2 bs)
202 where encode' b@[c1, c2] = let c = chr (read ("0x" ++ b))
205 escape i c1 c2 | i `elem` nonSpecialChars = [i]
206 | otherwise = "%" ++ [c1] ++ [c2]
208 nonSpecialChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_.~"
210 -- | Make arguments that should be posted to tracker.
211 -- This is a separate pure function for testability.
212 mkArgs :: PortNumber -> String -> Integer -> Integer -> Metainfo -> [(String, ByteString)]
213 mkArgs port peer_id up down m =
214 let fileSize = lengthInBytes $ info m
215 bytesLeft = fileSize - down
217 [("info_hash", pack . urlEncodeHash . B16.encode . infoHash $ m),
218 ("peer_id", pack . urlEncode $ peer_id),
219 ("port", pack $ show port),
220 ("uploaded", pack $ show up),
221 ("downloaded", pack $ show down),
222 ("left", pack $ show bytesLeft),
224 ("event", "started")]
226 trackerLoop :: PortNumber -> String -> Metainfo -> TState -> IO ByteString
227 trackerLoop port peerId m st = do
228 up <- readMVar $ uploaded st
229 down <- readMVar $ downloaded st
230 resp <- sendGetRequest (head . announceList $ m) $ mkArgs port peerId up down m
231 case Benc.decode resp of
232 Left e -> return $ pack (show e)
234 case mkTrackerResponse trackerInfo of
237 _ <- threadDelay $ fromIntegral (interval tresp)
238 _ <- putMVar (connectedPeers st) (peers tresp)
239 trackerLoop port peerId m st
242 getResponse :: Handle -> IO UDPResponse
244 -- connect packet is 16 bytes long
245 -- announce packet is atleast 20 bytes long
246 bs <- hGet h (16*1024)
247 return $ decode $ fromStrict bs
249 sendRequest :: Handle -> UDPRequest -> IO ()
250 sendRequest h req = hPut h bsReq
251 where bsReq = toStrict $ encode req
253 getTrackerType :: String -> TrackerProtocol
254 getTrackerType url | isPrefixOf "http://" url = Http
255 | isPrefixOf "udp://" url = Udp
256 | otherwise = UnknownProtocol