src/FuncTorrent/Tracker.hs

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