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