import Prelude hiding (lookup, splitAt)
+import System.IO (Handle)
+import Control.Applicative (liftA2)
import Control.Concurrent (threadDelay)
import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, readMVar, putMVar)
-import Data.ByteString (ByteString)
+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 (PortNumber)
import Network.HTTP.Base (urlEncode)
import qualified Data.ByteString.Base16 as B16 (encode)
-import FuncTorrent.Bencode (BVal(..), decode)
+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)
+
+data TrackerProtocol = Http
+ | Udp
+ | UnknownProtocol
+ deriving (Show)
+
-- | Tracker response
data TrackerResponse = TrackerResponse {
interval :: Integer
, incomplete :: Maybe Integer
} deriving (Show, Eq)
-data TrackerEventState = Started
+data TrackerEventState = None
+ | Started
| Stopped
| Completed
deriving (Show, Eq)
, 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 = Started
+ return $ TState { currentState = None
, connectedPeers = ps
, uploaded = up
, downloaded = down
, left = sz }
--- | Deserialize tracker response
-mkTrackerResponse :: BVal -> Either ByteString TrackerResponse
-mkTrackerResponse resp =
+-- | Deserialize HTTP tracker response
+parseTrackerResponse :: BVal -> Either ByteString TrackerResponse
+parseTrackerResponse resp =
case lookup "failure reason" body of
Just (Bstr err) -> Left err
Just _ -> Left "Unknown failure"
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
+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
up <- readMVar $ uploaded st
down <- readMVar $ downloaded st
resp <- sendGetRequest (head . announceList $ m) $ mkArgs port peerId up down m
- case decode resp of
+ case Benc.decode resp of
Left e -> return $ pack (show e)
Right trackerInfo ->
- case mkTrackerResponse trackerInfo of
+ case parseTrackerResponse 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