1 {-# LANGUAGE OverloadedStrings #-}
2 module FuncTorrent.Tracker
9 import Prelude hiding (lookup, splitAt)
11 import Control.Monad.IO.Class (liftIO)
12 import Control.Monad.Reader (ReaderT, ask, runReaderT)
13 import Data.ByteString (ByteString)
14 import Data.ByteString.Char8 as BC (pack, unpack, splitAt)
15 import Data.Char (chr)
16 import Data.List (intercalate)
17 import Data.Map as M (lookup)
18 import Network.HTTP.Base (urlEncode)
19 import qualified Data.ByteString.Base16 as B16 (encode)
21 import FuncTorrent.Bencode (BVal(..), decode)
22 import FuncTorrent.Metainfo (Info(..), Metainfo(..))
23 import FuncTorrent.Network (get)
24 import FuncTorrent.Peer (Peer(..))
25 import FuncTorrent.Utils (splitN)
28 data TrackerResponse = TrackerResponse {
29 interval :: Maybe Integer
31 , complete :: Maybe Integer
32 , incomplete :: Maybe Integer
35 -- | Deserialize tracker response
36 mkTrackerResponse :: BVal -> Either ByteString TrackerResponse
37 mkTrackerResponse resp =
38 case lookup "failure reason" body of
39 Just (Bstr err) -> Left err
40 Just _ -> Left "Unknown failure"
42 let (Just (Bint i)) = lookup "interval" body
43 (Just (Bstr peersBS)) = lookup "peers" body
44 pl = map makePeer (splitN 6 peersBS)
45 in Right TrackerResponse {
49 , incomplete = Nothing
54 toInt :: String -> Integer
57 toPort :: ByteString -> Integer
58 toPort = read . ("0x" ++) . unpack . B16.encode
60 toIP :: ByteString -> String
61 toIP = Data.List.intercalate "." .
62 map (show . toInt . ("0x" ++) . unpack) .
65 makePeer :: ByteString -> Peer
66 makePeer peer = Peer "" (toIP ip') (toPort port')
67 where (ip', port') = splitAt 4 peer
69 -- | Connect to a tracker and get peer info
70 tracker :: String -> ReaderT Metainfo IO ByteString
73 let args = mkArgs peer_id m
74 liftIO $ get (head . announceList $ m) $ args
76 getTrackerResponse :: String -> ReaderT Metainfo IO (Either ByteString TrackerResponse)
77 getTrackerResponse peerId = do
79 resp <- liftIO $ runReaderT (tracker peerId) m
81 Right trackerInfo -> liftIO $ return $ mkTrackerResponse trackerInfo
82 Left e -> return $ Left (pack (show e))
84 --- | URL encode hash as per RFC1738
86 --- REVIEW: Why is this not written in terms of `Network.HTTP.Base.urlEncode` or
87 --- equivalent library function?
88 urlEncodeHash :: ByteString -> String
89 urlEncodeHash bs = concatMap (encode' . unpack) (splitN 2 bs)
90 where encode' b@[c1, c2] = let c = chr (read ("0x" ++ b))
93 escape i c1 c2 | i `elem` nonSpecialChars = [i]
94 | otherwise = "%" ++ [c1] ++ [c2]
96 nonSpecialChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_.~"
98 -- | Make arguments that should be posted to tracker.
99 -- This is a separate pure function for testability.
100 mkArgs :: String -> Metainfo -> [(String, ByteString)]
101 mkArgs peer_id m = [("info_hash", pack . urlEncodeHash . B16.encode . infoHash $ m),
102 ("peer_id", pack . urlEncode $ peer_id),
106 ("left", pack . show . lengthInBytes $ info m),
108 ("event", "started")]