src/FuncTorrent/Tracker.hs

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