1 {-# LANGUAGE OverloadedStrings #-}
2 module FuncTorrent.Tracker
8 import Prelude hiding (lookup, splitAt)
10 import Control.Applicative (liftA2)
11 import Control.Concurrent (threadDelay)
12 import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, readMVar, putMVar)
13 import Data.Binary (Binary(..))
14 import Data.Binary.Put (putWord16be, putWord32be, putWord64be, putByteString)
15 import Data.Binary.Get (getWord16be, getWord32be)
16 import Data.ByteString (ByteString)
17 import Data.ByteString.Char8 as BC (pack, unpack, splitAt)
18 import Data.Char (chr)
19 import Data.List (intercalate)
20 import Data.Map as M (lookup)
21 import Network (PortNumber)
22 import Network.HTTP.Base (urlEncode)
23 import qualified Data.ByteString.Base16 as B16 (encode)
25 import FuncTorrent.Bencode (BVal(..), decode)
26 import FuncTorrent.Metainfo (Info(..), Metainfo(..))
27 import FuncTorrent.Network (sendGetRequest)
28 import FuncTorrent.Peer (Peer(..))
29 import FuncTorrent.Utils (splitN)
32 data TrackerResponse = TrackerResponse {
35 , complete :: Maybe Integer
36 , incomplete :: Maybe Integer
39 data TrackerEventState = None
45 data TState = TState {
46 uploaded :: MVar Integer
47 , downloaded :: MVar Integer
49 , currentState :: TrackerEventState
50 , connectedPeers :: MVar [Peer]
53 -- UDP tracker: http://bittorrent.org/beps/bep_0015.html
59 data UDPRequest = ConnectReq Integer
60 | AnnounceReq Integer Integer ByteString String Integer Integer Integer TrackerEventState Integer
61 | ScrapeReq Integer Integer ByteString
64 data UDPResponse = ConnectResp Integer Integer
65 | AnnounceResp Integer Integer Integer Integer Integer Integer
66 | ScrapeResp Integer Integer Integer Integer
69 actionToInteger :: Action -> Integer
70 actionToInteger Connect = 0
71 actionToInteger Announce = 1
72 actionToInteger Scrape = 2
74 intToAction :: Integer -> Action
75 intToAction 0 = Connect
76 intToAction 1 = Announce
77 intToAction 2 = Scrape
79 eventToInteger :: TrackerEventState -> Integer
80 eventToInteger None = 0
81 eventToInteger Completed = 1
82 eventToInteger Started = 2
83 eventToInteger Stopped = 3
85 instance Binary UDPRequest where
86 put (ConnectReq transId) = do
87 putWord64be 0x41727101980
88 putWord32be $ fromIntegral (actionToInteger Connect)
89 putWord32be (fromIntegral transId)
90 put (AnnounceReq connId transId infohash peerId down left up event port) = do
91 putWord64be $ fromIntegral connId
92 putWord32be $ fromIntegral (actionToInteger Announce)
93 putWord32be $ fromIntegral transId
94 putByteString infohash
95 putByteString (BC.pack peerId)
96 putWord64be (fromIntegral down)
97 putWord64be (fromIntegral left)
98 putWord64be (fromIntegral up)
99 putWord32be $ fromIntegral (eventToInteger None)
101 -- key is optional, we will not send it for now
102 putWord32be $ fromIntegral (-1)
103 putWord16be $ fromIntegral port
104 put (ScrapeReq _ _ _) = undefined
107 instance Binary UDPResponse where
110 a <- getWord32be -- action
112 0 -> liftA2 ConnectResp (fromIntegral <$> getWord32be) (fromIntegral <$> getWord32be)
114 tid <- fromIntegral <$> getWord32be
115 interval' <- fromIntegral <$> getWord32be
116 _ <- getWord32be -- leechers
117 _ <- getWord32be -- seeders
118 _ <- getWord32be -- ip
119 _ <- getWord16be -- port
120 return $ AnnounceResp tid interval' 0 0 0 0
122 tid <- fromIntegral <$> getWord32be
126 return $ ScrapeResp tid 0 0 0
127 _ -> error ("unknown response action type: " ++ show a)
129 initialTrackerState :: Integer -> IO TState
130 initialTrackerState sz = do
134 return $ TState { currentState = None
135 , connectedPeers = ps
140 -- | Deserialize tracker response
141 mkTrackerResponse :: BVal -> Either ByteString TrackerResponse
142 mkTrackerResponse resp =
143 case lookup "failure reason" body of
144 Just (Bstr err) -> Left err
145 Just _ -> Left "Unknown failure"
147 let (Just (Bint i)) = lookup "interval" body
148 (Just (Bstr peersBS)) = lookup "peers" body
149 pl = map makePeer (splitN 6 peersBS)
150 in Right TrackerResponse {
154 , incomplete = Nothing
159 toInt :: String -> Integer
162 toPort :: ByteString -> Integer
163 toPort = read . ("0x" ++) . unpack . B16.encode
165 toIP :: ByteString -> String
166 toIP = Data.List.intercalate "." .
167 map (show . toInt . ("0x" ++) . unpack) .
168 splitN 2 . B16.encode
170 makePeer :: ByteString -> Peer
171 makePeer peer = Peer "" (toIP ip') (toPort port')
172 where (ip', port') = splitAt 4 peer
174 --- | URL encode hash as per RFC1738
176 --- REVIEW: Why is this not written in terms of `Network.HTTP.Base.urlEncode` or
177 --- equivalent library function?
178 urlEncodeHash :: ByteString -> String
179 urlEncodeHash bs = concatMap (encode' . unpack) (splitN 2 bs)
180 where encode' b@[c1, c2] = let c = chr (read ("0x" ++ b))
183 escape i c1 c2 | i `elem` nonSpecialChars = [i]
184 | otherwise = "%" ++ [c1] ++ [c2]
186 nonSpecialChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_.~"
188 -- | Make arguments that should be posted to tracker.
189 -- This is a separate pure function for testability.
190 mkArgs :: PortNumber -> String -> Integer -> Integer -> Metainfo -> [(String, ByteString)]
191 mkArgs port peer_id up down m =
192 let fileSize = lengthInBytes $ info m
193 bytesLeft = fileSize - down
195 [("info_hash", pack . urlEncodeHash . B16.encode . infoHash $ m),
196 ("peer_id", pack . urlEncode $ peer_id),
197 ("port", pack $ show port),
198 ("uploaded", pack $ show up),
199 ("downloaded", pack $ show down),
200 ("left", pack $ show bytesLeft),
202 ("event", "started")]
204 trackerLoop :: PortNumber -> String -> Metainfo -> TState -> IO ByteString
205 trackerLoop port peerId m st = do
206 up <- readMVar $ uploaded st
207 down <- readMVar $ downloaded st
208 resp <- sendGetRequest (head . announceList $ m) $ mkArgs port peerId up down m
210 Left e -> return $ pack (show e)
212 case mkTrackerResponse trackerInfo of
215 _ <- threadDelay $ fromIntegral (interval tresp)
216 _ <- putMVar (connectedPeers st) (peers tresp)
217 trackerLoop port peerId m st