X-Git-Url: https://git.rkrishnan.org/?a=blobdiff_plain;f=src%2FFuncTorrent%2FTracker.hs;h=ac99ce288d23b208319abf0972a8c78255b1c0f9;hb=fceb1acb81be177e1d133ff533fa0a2ea17eddb6;hp=ab14b09e31920bb4da579e2a2c1a43d1693b80e9;hpb=ebc045715374d3418a0c1466f6ae95252603899c;p=functorrent.git diff --git a/src/FuncTorrent/Tracker.hs b/src/FuncTorrent/Tracker.hs index ab14b09..ac99ce2 100644 --- a/src/FuncTorrent/Tracker.hs +++ b/src/FuncTorrent/Tracker.hs @@ -1,104 +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 - (TrackerResponse(..), - getTrackerResponse - ) where - -import Prelude hiding (lookup, splitAt) - -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 (get) -import FuncTorrent.Peer (Peer(..)) -import FuncTorrent.Utils (splitN) --- | Tracker response -data TrackerResponse = TrackerResponse { - interval :: Maybe Integer - , peers :: [Peer] - , complete :: Maybe Integer - , incomplete :: Maybe Integer - } deriving (Show, Eq) - --- | 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 = Just i - , peers = pl - , complete = Nothing - , incomplete = Nothing - } +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.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 + ps <- newEmptyMVar + forkIO $ (getTrackerLoopFn turl) turl port peerId infohash fsChan (initialTState ps) + runStateT (msgHandler msgChannel) (initialTState ps) + return () + 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 | "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 - --- | Connect to a tracker and get peer info -tracker :: PortNumber -> String -> Metainfo -> IO ByteString -tracker port peer_id m = - get (head . announceList $ m) $ mkArgs port peer_id m - -getTrackerResponse :: PortNumber -> String -> Metainfo -> IO (Either ByteString TrackerResponse) -getTrackerResponse port peerId m = do - resp <- tracker port peerId m - case decode resp of - Right trackerInfo -> return $ mkTrackerResponse trackerInfo - Left e -> return $ Left (pack (show e)) - ---- | 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 -> Metainfo -> [(String, ByteString)] -mkArgs port peer_id m = [("info_hash", pack . urlEncodeHash . B16.encode . infoHash $ m), - ("peer_id", pack . urlEncode $ peer_id), - ("port", pack $ show port), - ("uploaded", "0"), - ("downloaded", "0"), - ("left", pack . show . lengthInBytes $ info m), - ("compact", "1"), - ("event", "started")] - - + 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