{-# LANGUAGE OverloadedStrings #-}
module FuncTorrent.Tracker
- (TrackerResponse(..),
- connect,
- mkArgs,
- mkParams,
- mkTrackerResponse,
- urlEncodeHash
+ (TState(..),
+ initialTrackerState,
+ trackerLoop,
) where
-import Prelude hiding (lookup, concat, replicate, splitAt)
+import Prelude hiding (lookup, splitAt)
-import Data.ByteString (ByteString)
-import Data.ByteString.Char8 as BC (pack, unpack, splitAt, concat, intercalate)
+import System.IO (Handle)
+import Control.Applicative (liftA2)
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, readMVar, putMVar)
+import Data.Binary (Binary(..), encode, decode)
+import Data.Binary.Put (putWord16be, putWord32be, putWord64be, putByteString)
+import Data.Binary.Get (Get, isEmpty, getByteString, getWord16be, getWord32be)
+import Data.ByteString (ByteString, hGet, hPut)
+import Data.ByteString.Char8 as BC (pack, unpack, splitAt)
+import Data.ByteString.Lazy (fromStrict, toStrict)
import Data.Char (chr)
-import Data.List (intercalate)
+import Data.List (intercalate, isPrefixOf)
import Data.Map as M (lookup)
-import Network.HTTP (simpleHTTP, defaultGETRequest_, getResponseBody)
+import Network (PortNumber)
import Network.HTTP.Base (urlEncode)
-import Network.URI (parseURI)
import qualified Data.ByteString.Base16 as B16 (encode)
import FuncTorrent.Bencode (BVal(..))
+import qualified FuncTorrent.Bencode as Benc
+import FuncTorrent.Metainfo (Info(..), Metainfo(..))
+import FuncTorrent.Network (sendGetRequest)
import FuncTorrent.Peer (Peer(..))
import FuncTorrent.Utils (splitN)
-import FuncTorrent.Metainfo (Info(..), Metainfo(..))
+data TrackerProtocol = Http
+ | Udp
+ | UnknownProtocol
+ deriving (Show)
+
-- | Tracker response
data TrackerResponse = TrackerResponse {
- interval :: Maybe Integer
- , peers :: [Peer]
- , complete :: Maybe Integer
- , incomplete :: Maybe Integer
- } deriving (Show, Eq)
+ interval :: Integer
+ , peers :: [Peer]
+ , complete :: Maybe Integer
+ , incomplete :: Maybe Integer
+ } deriving (Show, Eq)
+
+data TrackerEventState = None
+ | Started
+ | Stopped
+ | Completed
+ deriving (Show, Eq)
+
+data TState = TState {
+ uploaded :: MVar Integer
+ , downloaded :: MVar Integer
+ , left :: Integer
+ , currentState :: TrackerEventState
+ , connectedPeers :: MVar [Peer]
+ }
+
+-- UDP tracker: http://bittorrent.org/beps/bep_0015.html
+data Action = Connect
+ | Announce
+ | Scrape
+ deriving (Show, Eq)
+
+type IP = String
+type Port = Integer
+
+data UDPRequest = ConnectReq Integer
+ | AnnounceReq Integer Integer ByteString String Integer Integer Integer TrackerEventState Integer
+ | ScrapeReq Integer Integer ByteString
+ deriving (Show, Eq)
+
+data UDPResponse = ConnectResp Integer Integer -- transaction_id connection_id
+ | AnnounceResp Integer Integer Integer Integer [(IP, Port)] -- transaction_id interval leechers seeders [(ip, port)]
+ | ScrapeResp Integer Integer Integer Integer
+ deriving (Show, Eq)
+
+actionToInteger :: Action -> Integer
+actionToInteger Connect = 0
+actionToInteger Announce = 1
+actionToInteger Scrape = 2
+
+intToAction :: Integer -> Action
+intToAction 0 = Connect
+intToAction 1 = Announce
+intToAction 2 = Scrape
+
+eventToInteger :: TrackerEventState -> Integer
+eventToInteger None = 0
+eventToInteger Completed = 1
+eventToInteger Started = 2
+eventToInteger Stopped = 3
+
+instance Binary UDPRequest where
+ put (ConnectReq transId) = do
+ putWord64be 0x41727101980
+ putWord32be $ fromIntegral (actionToInteger Connect)
+ putWord32be (fromIntegral transId)
+ put (AnnounceReq connId transId infohash peerId down left up event port) = do
+ putWord64be $ fromIntegral connId
+ putWord32be $ fromIntegral (actionToInteger Announce)
+ putWord32be $ fromIntegral transId
+ putByteString infohash
+ putByteString (BC.pack peerId)
+ putWord64be (fromIntegral down)
+ putWord64be (fromIntegral left)
+ putWord64be (fromIntegral up)
+ putWord32be $ fromIntegral (eventToInteger None)
+ putWord32be 0
+ -- key is optional, we will not send it for now
+ putWord32be $ fromIntegral (-1)
+ putWord16be $ fromIntegral port
+ put (ScrapeReq _ _ _) = undefined
+ get = undefined
+
+instance Binary UDPResponse where
+ put = undefined
+ get = do
+ a <- getWord32be -- action
+ case a of
+ 0 -> liftA2 ConnectResp (fromIntegral <$> getWord32be) (fromIntegral <$> getWord32be)
+ 1 -> do
+ tid <- fromIntegral <$> getWord32be
+ interval' <- fromIntegral <$> getWord32be
+ _ <- getWord32be -- leechers
+ _ <- getWord32be -- seeders
+ ipportpairs <- getIPPortPairs -- [(ip, port)]
+ return $ AnnounceResp tid interval' 0 0 ipportpairs
+ 2 -> do
+ tid <- fromIntegral <$> getWord32be
+ _ <- getWord32be
+ _ <- getWord32be
+ _ <- getWord32be
+ return $ ScrapeResp tid 0 0 0
+ _ -> error ("unknown response action type: " ++ show a)
+
+getIPPortPairs :: Get [(IP, Port)]
+getIPPortPairs = do
+ empty <- isEmpty
+ if empty
+ then return []
+ else do
+ ip <- toIP <$> getByteString 6
+ port <- toPort <$> getByteString 2
+ ipportpairs <- getIPPortPairs
+ return $ (ip, port) : ipportpairs
+
+initialTrackerState :: Integer -> IO TState
+initialTrackerState sz = do
+ ps <- newEmptyMVar
+ up <- newMVar 0
+ down <- newMVar 0
+ return $ TState { currentState = None
+ , connectedPeers = ps
+ , uploaded = up
+ , downloaded = down
+ , left = sz }
-- | Deserialize tracker response
mkTrackerResponse :: BVal -> Either ByteString TrackerResponse
(Just (Bstr peersBS)) = lookup "peers" body
pl = map makePeer (splitN 6 peersBS)
in Right TrackerResponse {
- interval = Just i
+ interval = i
, peers = pl
, complete = Nothing
, incomplete = Nothing
where
(Bdict body) = resp
- toInt :: String -> Integer
- toInt = read
+toInt :: String -> Integer
+toInt = read
- toPort :: ByteString -> Integer
- toPort = read . ("0x" ++) . unpack . B16.encode
+makePeer :: ByteString -> Peer
+makePeer peer = Peer "" (toIP ip') (toPort port')
+ where (ip', port') = splitAt 4 peer
- toIP :: ByteString -> String
- toIP = Data.List.intercalate "." .
- map (show . toInt . ("0x" ++) . unpack) .
- splitN 2 . B16.encode
+toPort :: ByteString -> Port
+toPort = read . ("0x" ++) . unpack . B16.encode
- makePeer :: ByteString -> Peer
- makePeer peer = Peer (toIP ip') (toPort port')
- where (ip', port') = splitAt 4 peer
-
--- | Connect to a tracker and get peer info
-connect :: Metainfo -> String -> IO ByteString
-connect m peer_id = get (head . announceList $ m) $ mkArgs m peer_id
+toIP :: ByteString -> IP
+toIP = Data.List.intercalate "." .
+ map (show . toInt . ("0x" ++) . unpack) .
+ splitN 2 . B16.encode
--- | URL encode hash as per RFC1738
--- TODO: Add tests
-- | Make arguments that should be posted to tracker.
-- This is a separate pure function for testability.
-mkArgs :: Metainfo -> String -> [(String, ByteString)]
-mkArgs m peer_id = [("info_hash", pack . urlEncodeHash . B16.encode . infoHash $ m),
- ("peer_id", pack . urlEncode $ peer_id),
- ("port", "6881"),
- ("uploaded", "0"),
- ("downloaded", "0"),
- ("left", pack . show . lengthInBytes $ info m),
- ("compact", "1"),
- ("event", "started")]
-
--- | Make a query string from a alist of k, v
--- TODO: Url encode each argument
-mkParams :: [(String, ByteString)] -> ByteString
-mkParams params = BC.intercalate "&" [concat [pack f, "=", s] | (f,s) <- params]
-
-get :: String -> [(String, ByteString)] -> IO ByteString
-get url args = simpleHTTP (defaultGETRequest_ url') >>= getResponseBody
- where url' = case parseURI $ unpack $ concat [pack url, "?", qstr] of
- Just x -> x
- _ -> error "Bad tracker URL"
- qstr = mkParams args
+mkArgs :: PortNumber -> String -> Integer -> Integer -> Metainfo -> [(String, ByteString)]
+mkArgs port peer_id up down m =
+ let fileSize = lengthInBytes $ info m
+ bytesLeft = fileSize - down
+ in
+ [("info_hash", pack . urlEncodeHash . B16.encode . infoHash $ m),
+ ("peer_id", pack . urlEncode $ peer_id),
+ ("port", pack $ show port),
+ ("uploaded", pack $ show up),
+ ("downloaded", pack $ show down),
+ ("left", pack $ show bytesLeft),
+ ("compact", "1"),
+ ("event", "started")]
+
+trackerLoop :: PortNumber -> String -> Metainfo -> TState -> IO ByteString
+trackerLoop port peerId m st = do
+ up <- readMVar $ uploaded st
+ down <- readMVar $ downloaded st
+ resp <- sendGetRequest (head . announceList $ m) $ mkArgs port peerId up down m
+ case Benc.decode resp of
+ Left e -> return $ pack (show e)
+ Right trackerInfo ->
+ case mkTrackerResponse trackerInfo of
+ Left e -> return e
+ Right tresp -> do
+ _ <- threadDelay $ fromIntegral (interval tresp)
+ _ <- putMVar (connectedPeers st) (peers tresp)
+ trackerLoop port peerId m st
+
+-- udp tracker
+getResponse :: Handle -> IO UDPResponse
+getResponse h = do
+ -- connect packet is 16 bytes long
+ -- announce packet is atleast 20 bytes long
+ bs <- hGet h (16*1024)
+ return $ decode $ fromStrict bs
+
+sendRequest :: Handle -> UDPRequest -> IO ()
+sendRequest h req = hPut h bsReq
+ where bsReq = toStrict $ encode req
+
+getTrackerType :: String -> TrackerProtocol
+getTrackerType url | isPrefixOf "http://" url = Http
+ | isPrefixOf "udp://" url = Udp
+ | otherwise = UnknownProtocol
projects / functorrent.git / blobdiff