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