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                  | ErrorResp Integer String
  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       3 -> do -- error response
 142         tid <- fromIntegral <$> getWord32be
 143         bs  <- getByteString 4
 144         return $ ErrorResp tid $ unpack bs
 145       _ -> error ("unknown response action type: " ++ show a)
 146
 147 getIPPortPairs :: Get [(IP, Port)]
 148 getIPPortPairs = do
 149   empty <- isEmpty
 150   if empty
 151     then return []
 152     else do
 153     ip <- toIP <$> getByteString 6
 154     port <- toPort <$> getByteString 2
 155     ipportpairs <- getIPPortPairs
 156     return $ (ip, port) : ipportpairs
 157
 158 initialTrackerState :: Integer -> IO TState
 159 initialTrackerState sz = do
 160   ps <- newEmptyMVar
 161   up <- newMVar 0
 162   down <- newMVar 0
 163   return $ TState { currentState = None
 164                   , connectedPeers = ps
 165                   , uploaded = up
 166                   , downloaded = down
 167                   , left = sz }
 168
 169 -- | Deserialize HTTP tracker response
 170 parseTrackerResponse :: BVal -> Either ByteString TrackerResponse
 171 parseTrackerResponse resp =
 172     case lookup "failure reason" body of
 173       Just (Bstr err) -> Left err
 174       Just _ -> Left "Unknown failure"
 175       Nothing ->
 176           let (Just (Bint i)) = lookup "interval" body
 177               (Just (Bstr peersBS)) = lookup "peers" body
 178               pl = map makePeer (splitN 6 peersBS)
 179           in Right TrackerResponse {
 180                    interval = i
 181                  , peers = pl
 182                  , complete = Nothing
 183                  , incomplete = Nothing
 184                  }
 185     where
 186       (Bdict body) = resp
 187
 188 toInt :: String -> Integer
 189 toInt = read
 190
 191 makePeer :: ByteString -> Peer
 192 makePeer peer = Peer "" (toIP ip') (toPort port')
 193   where (ip', port') = splitAt 4 peer
 194
 195 toPort :: ByteString -> Port
 196 toPort = read . ("0x" ++) . unpack . B16.encode
 197
 198 toIP :: ByteString -> IP
 199 toIP = Data.List.intercalate "." .
 200        map (show . toInt . ("0x" ++) . unpack) .
 201        splitN 2 . B16.encode
 202
 203 --- | URL encode hash as per RFC1738
 204 --- TODO: Add tests
 205 --- REVIEW: Why is this not written in terms of `Network.HTTP.Base.urlEncode` or
 206 --- equivalent library function?
 207 urlEncodeHash :: ByteString -> String
 208 urlEncodeHash bs = concatMap (encode' . unpack) (splitN 2 bs)
 209   where encode' b@[c1, c2] = let c =  chr (read ("0x" ++ b))
 210                             in escape c c1 c2
 211         encode' _ = ""
 212         escape i c1 c2 | i `elem` nonSpecialChars = [i]
 213                        | otherwise = "%" ++ [c1] ++ [c2]
 214
 215         nonSpecialChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_.~"
 216
 217 -- | Make arguments that should be posted to tracker.
 218 -- This is a separate pure function for testability.
 219 mkArgs :: PortNumber -> String -> Integer -> Integer -> Metainfo -> [(String, ByteString)]
 220 mkArgs port peer_id up down m =
 221   let fileSize = lengthInBytes $ info m
 222       bytesLeft = fileSize - down
 223   in
 224     [("info_hash", pack . urlEncodeHash . B16.encode . infoHash $ m),
 225      ("peer_id", pack . urlEncode $ peer_id),
 226      ("port", pack $ show port),
 227      ("uploaded", pack $ show up),
 228      ("downloaded", pack $ show down),
 229      ("left", pack $ show bytesLeft),
 230      ("compact", "1"),
 231      ("event", "started")]
 232
 233 trackerLoop :: PortNumber -> String -> Metainfo -> TState -> IO ByteString
 234 trackerLoop port peerId m st = do
 235   up <- readMVar $ uploaded st
 236   down <- readMVar $ downloaded st
 237   resp <- sendGetRequest (head . announceList $ m) $ mkArgs port peerId up down m
 238   case Benc.decode resp of
 239     Left e -> return $ pack (show e)
 240     Right trackerInfo ->
 241       case parseTrackerResponse trackerInfo of
 242         Left e -> return e
 243         Right tresp -> do
 244           _ <- threadDelay $ fromIntegral (interval tresp)
 245           _ <- putMVar (connectedPeers st) (peers tresp)
 246           trackerLoop port peerId m st
 247
 248 -- udp tracker
 249 getResponse :: Socket -> IO UDPResponse
 250 getResponse s = do
 251   -- connect packet is 16 bytes long
 252   -- announce packet is atleast 20 bytes long
 253   bs <- recv s (16*1024)
 254   return $ decode $ fromStrict bs
 255
 256 sendRequest :: Socket -> String -> PortNumber -> UDPRequest -> IO ()
 257 sendRequest s ip port req = do
 258   hostaddr <- inet_addr ip
 259   _ <- sendTo s bsReq $ SockAddrInet (fromIntegral port) hostaddr
 260   return ()
 261     where bsReq = toStrict $ encode req
 262
 263 getTrackerType :: String -> TrackerProtocol
 264 getTrackerType url | isPrefixOf "http://" url = Http
 265                    | isPrefixOf "udp://" url  = Udp
 266                    | otherwise                = UnknownProtocol
 267
 268 udpTrackerLoop :: PortNumber -> String -> Metainfo -> TState -> IO String
 269 udpTrackerLoop port peerId m st = do
 270   -- h <- connectTo "exodus.desync.com" (PortNumber 6969)
 271   s <- socket AF_INET Datagram defaultProtocol
 272   hostAddr <- inet_addr "185.37.101.229"
 273   putStrLn "connected to tracker"
 274   _ <- sendTo s (toStrict $ encode (ConnectReq 42)) (SockAddrInet 2710 hostAddr)
 275   putStrLn "--> sent ConnectReq to tracker"
 276   resp <- recv s 16
 277   putStrLn "<-- recv ConnectResp from tracker"
 278   return $ show resp