src/FuncTorrent/Tracker.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module FuncTorrent.Tracker
   3     (TState(..),
   4      initialTrackerState,
   5      trackerLoop,
   6     ) where
   7
   8 import Prelude hiding (lookup, splitAt)
   9
  10 import System.IO (Handle)
  11 import Control.Applicative (liftA2)
  12 import Control.Concurrent (threadDelay)
  13 import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, readMVar, putMVar)
  14 import Data.Binary (Binary(..), encode, decode)
  15 import Data.Binary.Put (putWord16be, putWord32be, putWord64be, putByteString)
  16 import Data.Binary.Get (Get, isEmpty, getByteString, getWord16be, getWord32be)
  17 import Data.ByteString (ByteString, hGet, hPut)
  18 import Data.ByteString.Char8 as BC (pack, unpack, splitAt)
  19 import Data.ByteString.Lazy (fromStrict, toStrict)
  20 import Data.Char (chr)
  21 import Data.List (intercalate, isPrefixOf)
  22 import Data.Map as M (lookup)
  23 import Network (PortNumber)
  24 import Network.HTTP.Base (urlEncode)
  25 import qualified Data.ByteString.Base16 as B16 (encode)
  26
  27 import FuncTorrent.Bencode (BVal(..))
  28 import qualified FuncTorrent.Bencode as Benc
  29 import FuncTorrent.Metainfo (Info(..), Metainfo(..))
  30 import FuncTorrent.Network (sendGetRequest)
  31 import FuncTorrent.Peer (Peer(..))
  32 import FuncTorrent.Utils (splitN)
  33
  34
  35 data TrackerProtocol = Http
  36                      | Udp
  37                      | UnknownProtocol
  38                      deriving (Show)
  39
  40 -- | Tracker response
  41 data TrackerResponse = TrackerResponse {
  42   interval :: Integer
  43   , peers :: [Peer]
  44   , complete :: Maybe Integer
  45   , incomplete :: Maybe Integer
  46   } deriving (Show, Eq)
  47
  48 data TrackerEventState = None
  49                        | Started
  50                        | Stopped
  51                        | Completed
  52                        deriving (Show, Eq)
  53
  54 data TState = TState {
  55     uploaded :: MVar Integer
  56   , downloaded :: MVar Integer
  57   , left :: Integer
  58   , currentState :: TrackerEventState
  59   , connectedPeers :: MVar [Peer]
  60   }
  61
  62 -- UDP tracker: http://bittorrent.org/beps/bep_0015.html
  63 data Action = Connect
  64             | Announce
  65             | Scrape
  66             deriving (Show, Eq)
  67
  68 type IP = String
  69 type Port = Integer
  70
  71 data UDPRequest = ConnectReq Integer
  72                 | AnnounceReq Integer Integer ByteString String Integer Integer Integer TrackerEventState Integer
  73                 | ScrapeReq Integer Integer ByteString
  74                 deriving (Show, Eq)
  75
  76 data UDPResponse = ConnectResp Integer Integer -- transaction_id connection_id
  77                  | AnnounceResp Integer Integer Integer Integer [(IP, Port)] -- transaction_id interval leechers seeders [(ip, port)]
  78                  | ScrapeResp Integer Integer Integer Integer
  79                  deriving (Show, Eq)
  80
  81 actionToInteger :: Action -> Integer
  82 actionToInteger Connect  = 0
  83 actionToInteger Announce = 1
  84 actionToInteger Scrape   = 2
  85
  86 intToAction :: Integer -> Action
  87 intToAction 0 = Connect
  88 intToAction 1 = Announce
  89 intToAction 2 = Scrape
  90
  91 eventToInteger :: TrackerEventState -> Integer
  92 eventToInteger None = 0
  93 eventToInteger Completed = 1
  94 eventToInteger Started = 2
  95 eventToInteger Stopped = 3
  96
  97 instance Binary UDPRequest where
  98   put (ConnectReq transId) = do
  99     putWord64be 0x41727101980
 100     putWord32be $ fromIntegral (actionToInteger Connect)
 101     putWord32be (fromIntegral transId)
 102   put (AnnounceReq connId transId infohash peerId down left up event port) = do
 103     putWord64be $ fromIntegral connId
 104     putWord32be $ fromIntegral (actionToInteger Announce)
 105     putWord32be $ fromIntegral transId
 106     putByteString infohash
 107     putByteString (BC.pack peerId)
 108     putWord64be (fromIntegral down)
 109     putWord64be (fromIntegral left)
 110     putWord64be (fromIntegral up)
 111     putWord32be $ fromIntegral (eventToInteger None)
 112     putWord32be 0
 113     -- key is optional, we will not send it for now
 114     putWord32be $ fromIntegral (-1)
 115     putWord16be $ fromIntegral port
 116   put (ScrapeReq _ _ _) = undefined
 117   get = undefined
 118
 119 instance Binary UDPResponse where
 120   put = undefined
 121   get = do
 122     a <- getWord32be -- action
 123     case a of
 124       0 -> liftA2 ConnectResp (fromIntegral <$> getWord32be) (fromIntegral <$> getWord32be)
 125       1 -> do
 126         tid <- fromIntegral <$> getWord32be
 127         interval' <- fromIntegral <$> getWord32be
 128         _ <- getWord32be -- leechers
 129         _ <- getWord32be -- seeders
 130         ipportpairs <- getIPPortPairs -- [(ip, port)]
 131         return $ AnnounceResp tid interval' 0 0 ipportpairs
 132       2 -> do
 133         tid <- fromIntegral <$> getWord32be
 134         _ <- getWord32be
 135         _ <- getWord32be
 136         _ <- getWord32be
 137         return $ ScrapeResp tid 0 0 0
 138       _ -> error ("unknown response action type: " ++ show a)
 139
 140 getIPPortPairs :: Get [(IP, Port)]
 141 getIPPortPairs = do
 142   empty <- isEmpty
 143   if empty
 144     then return []
 145     else do
 146     ip <- toIP <$> getByteString 6
 147     port <- toPort <$> getByteString 2
 148     ipportpairs <- getIPPortPairs
 149     return $ (ip, port) : ipportpairs
 150
 151 initialTrackerState :: Integer -> IO TState
 152 initialTrackerState sz = do
 153   ps <- newEmptyMVar
 154   up <- newMVar 0
 155   down <- newMVar 0
 156   return $ TState { currentState = None
 157                   , connectedPeers = ps
 158                   , uploaded = up
 159                   , downloaded = down
 160                   , left = sz }
 161
 162 -- | Deserialize HTTP tracker response
 163 parseTrackerResponse :: BVal -> Either ByteString TrackerResponse
 164 parseTrackerResponse resp =
 165     case lookup "failure reason" body of
 166       Just (Bstr err) -> Left err
 167       Just _ -> Left "Unknown failure"
 168       Nothing ->
 169           let (Just (Bint i)) = lookup "interval" body
 170               (Just (Bstr peersBS)) = lookup "peers" body
 171               pl = map makePeer (splitN 6 peersBS)
 172           in Right TrackerResponse {
 173                    interval = i
 174                  , peers = pl
 175                  , complete = Nothing
 176                  , incomplete = Nothing
 177                  }
 178     where
 179       (Bdict body) = resp
 180
 181 toInt :: String -> Integer
 182 toInt = read
 183
 184 makePeer :: ByteString -> Peer
 185 makePeer peer = Peer "" (toIP ip') (toPort port')
 186   where (ip', port') = splitAt 4 peer
 187
 188 toPort :: ByteString -> Port
 189 toPort = read . ("0x" ++) . unpack . B16.encode
 190
 191 toIP :: ByteString -> IP
 192 toIP = Data.List.intercalate "." .
 193        map (show . toInt . ("0x" ++) . unpack) .
 194        splitN 2 . B16.encode
 195
 196 --- | URL encode hash as per RFC1738
 197 --- TODO: Add tests
 198 --- REVIEW: Why is this not written in terms of `Network.HTTP.Base.urlEncode` or
 199 --- equivalent library function?
 200 urlEncodeHash :: ByteString -> String
 201 urlEncodeHash bs = concatMap (encode' . unpack) (splitN 2 bs)
 202   where encode' b@[c1, c2] = let c =  chr (read ("0x" ++ b))
 203                             in escape c c1 c2
 204         encode' _ = ""
 205         escape i c1 c2 | i `elem` nonSpecialChars = [i]
 206                        | otherwise = "%" ++ [c1] ++ [c2]
 207
 208         nonSpecialChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_.~"
 209
 210 -- | Make arguments that should be posted to tracker.
 211 -- This is a separate pure function for testability.
 212 mkArgs :: PortNumber -> String -> Integer -> Integer -> Metainfo -> [(String, ByteString)]
 213 mkArgs port peer_id up down m =
 214   let fileSize = lengthInBytes $ info m
 215       bytesLeft = fileSize - down
 216   in
 217     [("info_hash", pack . urlEncodeHash . B16.encode . infoHash $ m),
 218      ("peer_id", pack . urlEncode $ peer_id),
 219      ("port", pack $ show port),
 220      ("uploaded", pack $ show up),
 221      ("downloaded", pack $ show down),
 222      ("left", pack $ show bytesLeft),
 223      ("compact", "1"),
 224      ("event", "started")]
 225
 226 trackerLoop :: PortNumber -> String -> Metainfo -> TState -> IO ByteString
 227 trackerLoop port peerId m st = do
 228   up <- readMVar $ uploaded st
 229   down <- readMVar $ downloaded st
 230   resp <- sendGetRequest (head . announceList $ m) $ mkArgs port peerId up down m
 231   case Benc.decode resp of
 232     Left e -> return $ pack (show e)
 233     Right trackerInfo ->
 234       case parseTrackerResponse trackerInfo of
 235         Left e -> return e
 236         Right tresp -> do
 237           _ <- threadDelay $ fromIntegral (interval tresp)
 238           _ <- putMVar (connectedPeers st) (peers tresp)
 239           trackerLoop port peerId m st
 240
 241 -- udp tracker
 242 getResponse :: Handle -> IO UDPResponse
 243 getResponse h = do
 244   -- connect packet is 16 bytes long
 245   -- announce packet is atleast 20 bytes long
 246   bs <- hGet h (16*1024)
 247   return $ decode $ fromStrict bs
 248
 249 sendRequest :: Handle -> UDPRequest -> IO ()
 250 sendRequest h req = hPut h bsReq
 251   where bsReq = toStrict $ encode req
 252
 253 getTrackerType :: String -> TrackerProtocol
 254 getTrackerType url | isPrefixOf "http://" url = Http
 255                    | isPrefixOf "udp://" url  = Udp
 256                    | otherwise                = UnknownProtocol