X-Git-Url: https://git.rkrishnan.org/?a=blobdiff_plain;f=src%2FFuncTorrent%2FTracker.hs;h=9873fe1513f073f05efe79b97b2e9bae1522e75e;hb=a533e0ed9679e77a3e50eb1786dbe3017a4e9928;hp=cf1648e1d44a9fd29287b1f46b7d1363d145377f;hpb=cfd13b8f2f31f0273331c8209d410748cfb39dc8;p=functorrent.git diff --git a/src/FuncTorrent/Tracker.hs b/src/FuncTorrent/Tracker.hs index cf1648e..9873fe1 100644 --- a/src/FuncTorrent/Tracker.hs +++ b/src/FuncTorrent/Tracker.hs @@ -1,138 +1,93 @@ +{- + - 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, - ) where - -import Prelude hiding (lookup, splitAt) - -import Control.Concurrent (threadDelay) -import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, readMVar, putMVar, takeMVar) -import Control.Monad.State -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) + (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, pack, unpack) +import Data.List (isPrefixOf) import Network (PortNumber) -import Network.HTTP.Base (urlEncode) -import qualified Data.ByteString.Base16 as B16 (encode) - -import FuncTorrent.Bencode (BVal(..), decode) -import FuncTorrent.Metainfo (Info(..), Metainfo(..)) -import FuncTorrent.Network (httpget) -import FuncTorrent.Peer (Peer(..)) -import FuncTorrent.Utils (splitN) --- | Tracker response -data TrackerResponse = TrackerResponse { - interval :: Integer - , peers :: [Peer] - , complete :: Maybe Integer - , incomplete :: Maybe Integer - } deriving (Show, Eq) +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 FuncTorrent.Utils (Port, toPort, getHostname) +import qualified FuncTorrent.FileSystem as FS (MsgChannel) +import FuncTorrent.Peer (Peer) -data TrackerEventState = Started - | Stopped - | Completed - deriving (Show, Eq) +type MsgChannel = Chan TrackerMsg -data TState = TState { - uploaded :: MVar Integer - , downloaded :: MVar Integer - , left :: Integer - , currentState :: TrackerEventState - , connectedPeers :: MVar [Peer] - } +newTracker :: IO MsgChannel +newTracker = newChan -initialTrackerState :: Integer -> IO TState -initialTrackerState sz = do +runTracker :: MsgChannel -> FS.MsgChannel -> ByteString -> PortNumber + -> String -> [String] -> Integer -> IO () +runTracker msgChannel fsChan infohash port peerId announceList sz = do ps <- newEmptyMVar - up <- newMVar 0 - down <- newMVar 0 - return $ TState { currentState = Started - , connectedPeers = ps - , uploaded = up - , downloaded = down - , left = sz } - --- | Deserialize tracker response -mkTrackerResponse :: BVal -> Either ByteString TrackerResponse -mkTrackerResponse 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 - } + let initialTState = TState { currentState = None + , connectedPeers = ps + , left = sz } + turl = head announceList + host = getHostname turl + case getTrackerType turl of + Http -> do + _ <- forkIO $ HT.trackerLoop turl port peerId infohash fsChan initialTState + runStateT (msgHandler msgChannel) initialTState + return () + Udp -> do + _ <- forkIO $ UT.trackerLoop turl (fromIntegral port) peerId infohash fsChan initialTState + return () + _ -> + error "Tracker Protocol unimplemented" + +getTrackerType :: String -> TrackerProtocol +getTrackerType url | "http://" `isPrefixOf` url = Http + | "udp://" `isPrefixOf` url = Udp + | otherwise = UnknownProtocol + + +msgHandler :: MsgChannel -> StateT TState IO () +msgHandler c = forever $ do + st <- get + peers <- liftIO $ readMVar (connectedPeers st) + msg <- liftIO recvMsg + liftIO $ sendResponse msg peers where - (Bdict body) = resp - - toInt :: String -> Integer - toInt = read - - toPort :: ByteString -> Integer - toPort = read . ("0x" ++) . unpack . B16.encode - - toIP :: ByteString -> String - toIP = Data.List.intercalate "." . - map (show . toInt . ("0x" ++) . unpack) . - splitN 2 . B16.encode - - makePeer :: ByteString -> Peer - makePeer peer = Peer "" (toIP ip') (toPort port') - where (ip', port') = splitAt 4 peer - ---- | 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 <- liftIO $ readMVar $ uploaded st - down <- liftIO $ readMVar $ downloaded st - resp <- liftIO $ httpget (head . announceList $ m) $ mkArgs port peerId up down m - case 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 - + 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