From: Ramakrishnan Muthukrishnan Date: Sat, 5 Mar 2016 14:50:56 +0000 (+0530) Subject: Tracker: refactor into http, udp and types modules X-Git-Url: https://git.rkrishnan.org/pf/content/en/seg/bcase/module-simplejson.tests.html?a=commitdiff_plain;h=eac229d7b955396099b2123554ffd1f18142a85c;p=functorrent.git Tracker: refactor into http, udp and types modules --- diff --git a/functorrent.cabal b/functorrent.cabal index c4da29d..95196fb 100644 --- a/functorrent.cabal +++ b/functorrent.cabal @@ -26,6 +26,8 @@ library FuncTorrent.PieceManager, FuncTorrent.Server, FuncTorrent.Tracker, + FuncTorrent.Tracker.Http, + FuncTorrent.Tracker.Types, FuncTorrent.Utils other-extensions: OverloadedStrings diff --git a/src/FuncTorrent/Tracker.hs b/src/FuncTorrent/Tracker.hs index dd66c12..64a2ce9 100644 --- a/src/FuncTorrent/Tracker.hs +++ b/src/FuncTorrent/Tracker.hs @@ -2,158 +2,14 @@ module FuncTorrent.Tracker (TState(..), initialTrackerState, - trackerLoop, - udpTrackerLoop + trackerLoop ) where -import Prelude hiding (lookup, splitAt) +import Control.Concurrent.MVar (newEmptyMVar, newMVar) +import Data.List (isPrefixOf) - -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, isPrefixOf) -import Data.Map as M (lookup) -import Network (connectTo, PortID(..), PortNumber, Socket) -import Network.Socket (defaultProtocol, SocketType( Datagram ), Family( AF_INET ), SockAddr( SockAddrInet ), inet_addr, socket) -import Network.Socket.ByteString (sendTo, recv) -import Network.HTTP.Base (urlEncode) -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) - -data TrackerProtocol = Http - | Udp - | UnknownProtocol - deriving (Show) - --- | Tracker response -data TrackerResponse = TrackerResponse { - 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 - | ErrorResp Integer String - 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 - 3 -> do -- error response - tid <- fromIntegral <$> getWord32be - bs <- getByteString 4 - return $ ErrorResp tid $ unpack bs - _ -> 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 +import FuncTorrent.Tracker.Http(trackerLoop) +import FuncTorrent.Tracker.Types(TState(..), TrackerEventState(..), TrackerProtocol(..)) initialTrackerState :: Integer -> IO TState initialTrackerState sz = do @@ -166,113 +22,8 @@ initialTrackerState sz = do , downloaded = down , left = sz } --- | 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" - Nothing -> - let (Just (Bint i)) = lookup "interval" body - (Just (Bstr peersBS)) = lookup "peers" body - pl = map makePeer (splitN 6 peersBS) - in Right TrackerResponse { - interval = i - , peers = pl - , complete = Nothing - , incomplete = Nothing - } - where - (Bdict body) = resp - -toInt :: String -> Integer -toInt = read - -makePeer :: ByteString -> Peer -makePeer peer = Peer "" (toIP ip') (toPort port') - where (ip', port') = splitAt 4 peer - -toPort :: ByteString -> Port -toPort = read . ("0x" ++) . unpack . B16.encode - -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 ---- REVIEW: Why is this not written in terms of `Network.HTTP.Base.urlEncode` or ---- equivalent library function? -urlEncodeHash :: ByteString -> String -urlEncodeHash bs = concatMap (encode' . unpack) (splitN 2 bs) - where encode' b@[c1, c2] = let c = chr (read ("0x" ++ b)) - in escape c c1 c2 - encode' _ = "" - escape i c1 c2 | i `elem` nonSpecialChars = [i] - | otherwise = "%" ++ [c1] ++ [c2] - - nonSpecialChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_.~" - --- | Make arguments that should be posted to tracker. --- This is a separate pure function for testability. -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 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 :: Socket -> IO UDPResponse -getResponse s = do - -- connect packet is 16 bytes long - -- announce packet is atleast 20 bytes long - bs <- recv s (16*1024) - return $ decode $ fromStrict bs - -sendRequest :: Socket -> String -> PortNumber -> UDPRequest -> IO () -sendRequest s ip port req = do - hostaddr <- inet_addr ip - _ <- sendTo s bsReq $ SockAddrInet (fromIntegral port) hostaddr - return () - where bsReq = toStrict $ encode req - getTrackerType :: String -> TrackerProtocol getTrackerType url | isPrefixOf "http://" url = Http | isPrefixOf "udp://" url = Udp | otherwise = UnknownProtocol -udpTrackerLoop :: PortNumber -> String -> Metainfo -> TState -> IO String -udpTrackerLoop port peerId m st = do - -- h <- connectTo "exodus.desync.com" (PortNumber 6969) - s <- socket AF_INET Datagram defaultProtocol - hostAddr <- inet_addr "185.37.101.229" - putStrLn "connected to tracker" - _ <- sendTo s (toStrict $ encode (ConnectReq 42)) (SockAddrInet 2710 hostAddr) - putStrLn "--> sent ConnectReq to tracker" - resp <- recv s 16 - putStrLn "<-- recv ConnectResp from tracker" - return $ show resp diff --git a/src/FuncTorrent/Tracker/Http.hs b/src/FuncTorrent/Tracker/Http.hs new file mode 100644 index 0000000..dacadbf --- /dev/null +++ b/src/FuncTorrent/Tracker/Http.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE OverloadedStrings #-} +module FuncTorrent.Tracker.Http + ( trackerLoop + ) where + +import Prelude hiding (lookup, splitAt) + +import Control.Concurrent (threadDelay) +import Control.Concurrent.MVar (readMVar, putMVar) +import qualified Data.ByteString.Base16 as B16 (encode) +import Data.ByteString (ByteString) +import Data.ByteString.Char8 as BC (pack, unpack, splitAt) +import Data.Char (chr) +import Data.List (intercalate) +import Data.Map as M (lookup) +import Network (PortNumber) +import Network.HTTP.Base (urlEncode) + +import qualified FuncTorrent.Bencode as Benc +import FuncTorrent.Bencode (BVal(..)) +import FuncTorrent.Metainfo (Info(..), Metainfo(..)) +import FuncTorrent.Network (sendGetRequest) +import FuncTorrent.Peer (Peer(..)) +import FuncTorrent.Utils (splitN) +import FuncTorrent.Tracker.Types(TState(..), TrackerResponse(..), Port, IP) + + +--- | URL encode hash as per RFC1738 +--- TODO: Add tests +--- REVIEW: Why is this not written in terms of `Network.HTTP.Base.urlEncode` or +--- equivalent library function? +urlEncodeHash :: ByteString -> String +urlEncodeHash bs = concatMap (encode' . unpack) (splitN 2 bs) + where encode' b@[c1, c2] = let c = chr (read ("0x" ++ b)) + in escape c c1 c2 + encode' _ = "" + escape i c1 c2 | i `elem` nonSpecialChars = [i] + | otherwise = "%" ++ [c1] ++ [c2] + + nonSpecialChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_.~" + +-- | Make arguments that should be posted to tracker. +-- This is a separate pure function for testability. +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 parseTrackerResponse trackerInfo of + Left e -> return e + Right tresp -> do + _ <- threadDelay $ fromIntegral (interval tresp) + _ <- putMVar (connectedPeers st) (peers tresp) + trackerLoop port peerId m st + +parseTrackerResponse :: BVal -> Either ByteString TrackerResponse +parseTrackerResponse resp = + case lookup "failure reason" body of + Just (Bstr err) -> Left err + Just _ -> Left "Unknown failure" + Nothing -> + let (Just (Bint i)) = lookup "interval" body + (Just (Bstr peersBS)) = lookup "peers" body + pl = map makePeer (splitN 6 peersBS) + in Right TrackerResponse { + interval = i + , peers = pl + , complete = Nothing + , incomplete = Nothing + } + where + (Bdict body) = resp + +makePeer :: ByteString -> Peer +makePeer peer = Peer "" (toIP ip') (toPort port') + where (ip', port') = splitAt 4 peer + +toPort :: ByteString -> Port +toPort = read . ("0x" ++) . unpack . B16.encode + +toIP :: ByteString -> IP +toIP = Data.List.intercalate "." . + map (show . toInt . ("0x" ++) . unpack) . + splitN 2 . B16.encode + +toInt :: String -> Integer +toInt = read diff --git a/src/FuncTorrent/Tracker/Types.hs b/src/FuncTorrent/Tracker/Types.hs new file mode 100644 index 0000000..6ca5ddb --- /dev/null +++ b/src/FuncTorrent/Tracker/Types.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} +module FuncTorrent.Tracker.Types + ( TrackerProtocol(..) + , TrackerResponse(..) + , TrackerEventState(..) + , TState(..) + , IP + , Port + ) where + +import Control.Concurrent.MVar (MVar) + +import FuncTorrent.Peer (Peer(..)) + +type IP = String +type Port = Integer + +data TrackerProtocol = Http + | Udp + | UnknownProtocol + deriving (Show) + +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] + } + +-- | Tracker response +data TrackerResponse = TrackerResponse { + interval :: Integer + , peers :: [Peer] + , complete :: Maybe Integer + , incomplete :: Maybe Integer + } deriving (Show, Eq) diff --git a/src/main/Main.hs b/src/main/Main.hs index 623fe31..268e9a4 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -12,7 +12,7 @@ import FuncTorrent.Metainfo (Info(..), Metainfo(..), torrentToMetainfo import FuncTorrent.Peer (handlePeerMsgs) import FuncTorrent.PieceManager (initPieceMap) import qualified FuncTorrent.Server as Server -import FuncTorrent.Tracker (connectedPeers, initialTrackerState, trackerLoop, udpTrackerLoop) +import FuncTorrent.Tracker (connectedPeers, initialTrackerState, trackerLoop) import Network (PortID (PortNumber)) import System.IO (withFile, IOMode (ReadWriteMode)) import System.Directory (doesFileExist)