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 Control.Monad (forever)
  11 import qualified Data.ByteString.Base16 as B16 (encode)
  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 (PortNumber)
  18 import Network.HTTP.Base (urlEncode)
  19
  20 import qualified FuncTorrent.Bencode as Benc
  21 import FuncTorrent.Bencode (BVal(..))
  22 import qualified FuncTorrent.FileSystem as FS (MsgChannel, Stats(..), getStats)
  23 import FuncTorrent.Network (sendGetRequest)
  24 import FuncTorrent.Peer (Peer(..))
  25 import FuncTorrent.Utils (splitN)
  26 import FuncTorrent.Tracker.Types(TState(..), TrackerResponse(..), Port, IP)
  27
  28
  29 --- | URL encode hash as per RFC1738
  30 --- TODO: Add tests
  31 --- REVIEW: Why is this not written in terms of `Network.HTTP.Base.urlEncode` or
  32 --- equivalent library function?
  33 urlEncodeHash :: ByteString -> String
  34 urlEncodeHash bs = concatMap (encode' . unpack) (splitN 2 bs)
  35   where encode' b@[c1, c2] = let c =  chr (read ("0x" ++ b))
  36                             in escape c c1 c2
  37         encode' _ = ""
  38         escape i c1 c2 | i `elem` nonSpecialChars = [i]
  39                        | otherwise = "%" ++ [c1] ++ [c2]
  40
  41         nonSpecialChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_.~"
  42
  43 -- | Make arguments that should be posted to tracker.
  44 -- This is a separate pure function for testability.
  45 mkArgs :: PortNumber -> String -> Integer -> Integer -> Integer -> ByteString -> [(String, ByteString)]
  46 mkArgs port peer_id up down left' infoHash =
  47   [("info_hash", pack . urlEncodeHash . B16.encode $ infoHash),
  48    ("peer_id", pack . urlEncode $ peer_id),
  49    ("port", pack $ show port),
  50    ("uploaded", pack $ show up),
  51    ("downloaded", pack $ show down),
  52    ("left", pack $ show left'),
  53    ("compact", "1"),
  54    ("event", "started")]
  55
  56 trackerLoop :: String -> PortNumber -> String -> ByteString -> FS.MsgChannel -> TState -> IO ()
  57 trackerLoop url port peerId infohash fschan tstate = forever $ do
  58   st' <- FS.getStats fschan
  59   st <- readMVar st'
  60   let up = FS.bytesRead st
  61       down = FS.bytesWritten st
  62   resp <- sendGetRequest url $ mkArgs port peerId up down (left tstate) infohash
  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 tstate) (peers tresp)
  71           return () -- trackerLoop port peerId 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