X-Git-Url: https://git.rkrishnan.org/?a=blobdiff_plain;f=src%2FFuncTorrent%2FTracker.hs;h=b9e977acff1bea112cfc1090ac5f93c85b0cc6a9;hb=aa5477676dd98fb07a2afa118c29f98a4885fdc9;hp=b07fd2546f20912c6f7a07c9f9621a6dd5df9d83;hpb=552950e6fde25e0deacebf4faa438ae9c741c7a3;p=functorrent.git diff --git a/src/FuncTorrent/Tracker.hs b/src/FuncTorrent/Tracker.hs index b07fd25..b9e977a 100644 --- a/src/FuncTorrent/Tracker.hs +++ b/src/FuncTorrent/Tracker.hs @@ -1,274 +1,90 @@ +{- + - Copyright (C) 2015-2016 Ramakrishnan Muthukrishnan + - + - This file is part of FuncTorrent. + - + - FuncTorrent is free software; you can redistribute it and/or modify + - it under the terms of the GNU General Public License as published by + - the Free Software Foundation; either version 3 of the License, or + - (at your option) any later version. + - + - FuncTorrent is distributed in the hope that it will be useful, + - but WITHOUT ANY WARRANTY; without even the implied warranty of + - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + - GNU General Public License for more details. + - + - You should have received a copy of the GNU General Public License + - along with FuncTorrent; if not, see + -} + {-# LANGUAGE OverloadedStrings #-} module FuncTorrent.Tracker - (TState(..), - initialTrackerState, - trackerLoop, - udpTrackerLoop - ) where - -import Prelude hiding (lookup, splitAt) - - -import Control.Applicative (liftA2) -import Control.Concurrent (threadDelay) -import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, readMVar, putMVar) -import Control.Exception (try) -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 - 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 + (runTracker + , getConnectedPeers + , newTracker + ) where + +import Control.Concurrent(forkIO) +import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar) +import Control.Monad.State (StateT, liftIO, get, runStateT) +import Control.Monad (forever) +import Data.ByteString.Char8 (ByteString) +import Data.List (isPrefixOf) +import Network (PortNumber) + +import qualified FuncTorrent.Tracker.Http as HT (trackerLoop) +import qualified FuncTorrent.Tracker.Udp as UT (trackerLoop) +import FuncTorrent.Tracker.Types (TState(..), TrackerEventState(..), TrackerProtocol(..), TrackerMsg(..)) +import qualified FuncTorrent.FileSystem as FS (MsgChannel) +import FuncTorrent.PeerMsgs (Peer) + +type MsgChannel = Chan TrackerMsg + +newTracker :: IO MsgChannel +newTracker = newChan + +runTracker :: MsgChannel -> FS.MsgChannel -> ByteString -> PortNumber + -> String -> [String] -> Integer -> IO () +runTracker msgChannel fsChan infohash port peerId announceList sz = do + let fn = getTrackerLoopFn turl ps <- newEmptyMVar - up <- newMVar 0 - down <- newMVar 0 - return $ TState { currentState = None - , connectedPeers = ps - , uploaded = up - , 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 + _ <- forkIO $ fn turl port peerId infohash fsChan (initialTState ps) + _ <- runStateT (msgHandler msgChannel) (initialTState ps) return () - where bsReq = toStrict $ encode req + where getTrackerLoopFn turl' = + case getTrackerType turl' of + Http -> HT.trackerLoop + Udp -> UT.trackerLoop + _ -> error "Tracker Protocol unimplemented" + initialTState ps' = TState { currentState = None + , connectedPeers = ps' + , left = sz } + turl = head announceList getTrackerType :: String -> TrackerProtocol -getTrackerType url | isPrefixOf "http://" url = Http - | isPrefixOf "udp://" url = Udp - | otherwise = UnknownProtocol +getTrackerType url | "http://" `isPrefixOf` url = Http + | "udp://" `isPrefixOf` 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 + +msgHandler :: MsgChannel -> StateT TState IO () +msgHandler c = forever $ do + st <- get + peers <- liftIO $ readMVar (connectedPeers st) + msg <- liftIO recvMsg + liftIO $ sendResponse msg peers + where + recvMsg = readChan c + sendResponse msg peers = + case msg of + GetConnectedPeersMsg var -> + putMVar var peers + _ -> + putStrLn "Unhandled Tracker Msg" + +getConnectedPeers :: MsgChannel -> IO [Peer] +getConnectedPeers c = do + v <- newEmptyMVar + writeChan c (GetConnectedPeersMsg v) + readMVar v