src/FuncTorrent/Tracker.hs

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