src/FuncTorrent/Tracker.hs

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