src/FuncTorrent/Tracker.hs

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