src/FuncTorrent/Tracker/Http.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module FuncTorrent.Tracker.Http
   3        ( trackerLoop
   4        ) where
   5
   6 import Prelude hiding (lookup, splitAt)
   7
   8 import Control.Concurrent (threadDelay)
   9 import Control.Concurrent.MVar (readMVar, putMVar)
  10 import qualified Data.ByteString.Base16 as B16 (encode)
  11 import Data.ByteString (ByteString)
  12 import Data.ByteString.Char8 as BC (pack, unpack, splitAt)
  13 import Data.Char (chr)
  14 import Data.List (intercalate)
  15 import Data.Map as M (lookup)
  16 import Network (PortNumber)
  17 import Network.HTTP.Base (urlEncode)
  18
  19 import qualified FuncTorrent.Bencode as Benc
  20 import FuncTorrent.Bencode (BVal(..))
  21 import FuncTorrent.Metainfo (Info(..), Metainfo(..))
  22 import FuncTorrent.Network (sendGetRequest)
  23 import FuncTorrent.Peer (Peer(..))
  24 import FuncTorrent.Utils (splitN)
  25 import FuncTorrent.Tracker.Types(TState(..), TrackerResponse(..), Port, IP)
  26
  27
  28 --- | URL encode hash as per RFC1738
  29 --- TODO: Add tests
  30 --- REVIEW: Why is this not written in terms of `Network.HTTP.Base.urlEncode` or
  31 --- equivalent library function?
  32 urlEncodeHash :: ByteString -> String
  33 urlEncodeHash bs = concatMap (encode' . unpack) (splitN 2 bs)
  34   where encode' b@[c1, c2] = let c =  chr (read ("0x" ++ b))
  35                             in escape c c1 c2
  36         encode' _ = ""
  37         escape i c1 c2 | i `elem` nonSpecialChars = [i]
  38                        | otherwise = "%" ++ [c1] ++ [c2]
  39
  40         nonSpecialChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_.~"
  41
  42 -- | Make arguments that should be posted to tracker.
  43 -- This is a separate pure function for testability.
  44 mkArgs :: PortNumber -> String -> Integer -> Integer -> Metainfo -> [(String, ByteString)]
  45 mkArgs port peer_id up down m =
  46   let fileSize = lengthInBytes $ info m
  47       bytesLeft = fileSize - down
  48   in
  49     [("info_hash", pack . urlEncodeHash . B16.encode . infoHash $ m),
  50      ("peer_id", pack . urlEncode $ peer_id),
  51      ("port", pack $ show port),
  52      ("uploaded", pack $ show up),
  53      ("downloaded", pack $ show down),
  54      ("left", pack $ show bytesLeft),
  55      ("compact", "1"),
  56      ("event", "started")]
  57
  58 trackerLoop :: PortNumber -> String -> Metainfo -> TState -> IO ByteString
  59 trackerLoop port peerId m st = do
  60   up <- readMVar $ uploaded st
  61   down <- readMVar $ downloaded st
  62   resp <- sendGetRequest (head . announceList $ m) $ mkArgs port peerId up down m
  63   case Benc.decode resp of
  64     Left e -> return $ pack (show e)
  65     Right trackerInfo ->
  66       case parseTrackerResponse trackerInfo of
  67         Left e -> return e
  68         Right tresp -> do
  69           _ <- threadDelay $ fromIntegral (interval tresp)
  70           _ <- putMVar (connectedPeers st) (peers tresp)
  71           trackerLoop port peerId m st
  72
  73 parseTrackerResponse :: BVal -> Either ByteString TrackerResponse
  74 parseTrackerResponse resp =
  75     case lookup "failure reason" body of
  76       Just (Bstr err) -> Left err
  77       Just _ -> Left "Unknown failure"
  78       Nothing ->
  79           let (Just (Bint i)) = lookup "interval" body
  80               (Just (Bstr peersBS)) = lookup "peers" body
  81               pl = map makePeer (splitN 6 peersBS)
  82           in Right TrackerResponse {
  83                    interval = i
  84                  , peers = pl
  85                  , complete = Nothing
  86                  , incomplete = Nothing
  87                  }
  88     where
  89       (Bdict body) = resp
  90
  91 makePeer :: ByteString -> Peer
  92 makePeer peer = Peer "" (toIP ip') (toPort port')
  93   where (ip', port') = splitAt 4 peer
  94
  95 toPort :: ByteString -> Port
  96 toPort = read . ("0x" ++) . unpack . B16.encode
  97
  98 toIP :: ByteString -> IP
  99 toIP = Data.List.intercalate "." .
 100        map (show . toInt . ("0x" ++) . unpack) .
 101        splitN 2 . B16.encode
 102
 103 toInt :: String -> Integer
 104 toInt = read