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 (PortNumber)
  15 import Network.HTTP.Base (urlEncode)
  16 import qualified Data.ByteString.Base16 as B16 (encode)
  17
  18 import FuncTorrent.Bencode (BVal(..), decode)
  19 import FuncTorrent.Metainfo (Info(..), Metainfo(..))
  20 import FuncTorrent.Network (get)
  21 import FuncTorrent.Peer (Peer(..))
  22 import FuncTorrent.Utils (splitN)
  23
  24 -- | Tracker response
  25 data TrackerResponse = TrackerResponse {
  26       interval :: Maybe Integer
  27     , peers :: [Peer]
  28     , complete :: Maybe Integer
  29     , incomplete :: Maybe Integer
  30     } deriving (Show, Eq)
  31
  32 -- | Deserialize tracker response
  33 mkTrackerResponse :: BVal -> Either ByteString TrackerResponse
  34 mkTrackerResponse resp =
  35     case lookup "failure reason" body of
  36       Just (Bstr err) -> Left err
  37       Just _ -> Left "Unknown failure"
  38       Nothing ->
  39           let (Just (Bint i)) = lookup "interval" body
  40               (Just (Bstr peersBS)) = lookup "peers" body
  41               pl = map makePeer (splitN 6 peersBS)
  42           in Right TrackerResponse {
  43                    interval = Just i
  44                  , peers = pl
  45                  , complete = Nothing
  46                  , incomplete = Nothing
  47                  }
  48     where
  49       (Bdict body) = resp
  50
  51       toInt :: String -> Integer
  52       toInt = read
  53
  54       toPort :: ByteString -> Integer
  55       toPort = read . ("0x" ++) . unpack . B16.encode
  56
  57       toIP :: ByteString -> String
  58       toIP = Data.List.intercalate "." .
  59              map (show . toInt . ("0x" ++) . unpack) .
  60                  splitN 2 . B16.encode
  61
  62       makePeer :: ByteString -> Peer
  63       makePeer peer = Peer "" (toIP ip') (toPort port')
  64           where (ip', port') = splitAt 4 peer
  65
  66 -- | Connect to a tracker and get peer info
  67 tracker :: PortNumber -> String -> Metainfo -> IO ByteString
  68 tracker port peer_id m =
  69   get (head . announceList $ m) $ mkArgs port peer_id m
  70
  71 getTrackerResponse :: PortNumber -> String -> Metainfo -> IO (Either ByteString TrackerResponse)
  72 getTrackerResponse port peerId m = do
  73   resp <- tracker port peerId m
  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 :: PortNumber -> String -> Metainfo -> [(String, ByteString)]
  95 mkArgs port peer_id m = [("info_hash", pack . urlEncodeHash . B16.encode . infoHash $ m),
  96                          ("peer_id", pack . urlEncode $ peer_id),
  97                          ("port", pack $ show port),
  98                          ("uploaded", "0"),
  99                          ("downloaded", "0"),
 100                          ("left", pack . show . lengthInBytes $ info m),
 101                          ("compact", "1"),
 102                          ("event", "started")]
 103
 104