src/FuncTorrent/Tracker.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module FuncTorrent.Tracker
   3     (TrackerResponse(..),
   4      connect,
   5      mkTrackerResponse,
   6      prepareRequest,
   7      urlEncodeHash
   8     ) where
   9
  10 import Prelude hiding (lookup, concat, replicate, splitAt)
  11 import Data.ByteString.Char8 (ByteString, unpack, splitAt)
  12 import Data.Char (chr)
  13 import Data.List (intercalate)
  14 import Data.Map as M (lookup)
  15 import Data.Maybe (fromJust)
  16 import Network.HTTP (simpleHTTP, defaultGETRequest_, getResponseBody)
  17 import Network.HTTP.Base (urlEncode)
  18 import Network.URI (parseURI)
  19 import qualified Data.ByteString.Base16 as B16 (encode)
  20
  21 import FuncTorrent.Bencode (BVal(..), InfoDict)
  22 import FuncTorrent.Metainfo (infoHash)
  23 import FuncTorrent.Peer (Peer(..))
  24 import FuncTorrent.Utils (splitN)
  25
  26
  27 -- | Tracker response
  28 data TrackerResponse = TrackerResponse {
  29       interval :: Maybe Integer
  30     , peers :: [Peer]
  31     , complete :: Maybe Integer
  32     , incomplete :: Maybe Integer
  33     } deriving (Show, Eq)
  34
  35 type Url = String
  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 = 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
  72 -- | urlEncodeHash
  73 --
  74 -- >>> urlEncodeHash $ pack "123456789abcdef123456789abcdef123456789a"
  75 -- "%124Vx%9a%bc%de%f1%23Eg%89%ab%cd%ef%124Vx%9a"
  76 urlEncodeHash :: ByteString -> String
  77 urlEncodeHash bs = concatMap (encode' . unpack) (splitN 2 bs)
  78   where encode' b@[c1, c2] = let c =  chr (read ("0x" ++ b))
  79                             in escape c c1 c2
  80         encode' _ = ""
  81         escape i c1 c2 | i `elem` nonSpecialChars = [i]
  82                        | otherwise = "%" ++ [c1] ++ [c2]
  83
  84         nonSpecialChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_.~"
  85
  86 prepareRequest :: InfoDict -> String -> Integer -> String
  87 prepareRequest d peer_id len =
  88   let p = [("info_hash", urlEncodeHash ((B16.encode . infoHash) d)),
  89            ("peer_id", urlEncode peer_id),
  90            ("port", "6881"),
  91            ("uploaded", "0"),
  92            ("downloaded", "0"),
  93            ("left", show len),
  94            ("compact", "1"),
  95            ("event", "started")]
  96   in intercalate "&" [f ++ "=" ++ s | (f,s) <- p]
  97
  98 connect :: Url -> String -> IO ByteString
  99 connect baseurl qstr = simpleHTTP (defaultGETRequest_ url) >>= getResponseBody
 100     where url = fromJust . parseURI $ (baseurl ++ "?" ++ qstr)