From 12cbb3af2413dc28838ed271351dda16df8f7bdb Mon Sep 17 00:00:00 2001 From: joe Date: Fri, 15 Sep 2017 06:22:10 -0400 Subject: Separating dht-client library from bittorrent package. --- .../src/Network/BitTorrent/Tracker/Session.hs | 306 +++++++++++++++++++++ 1 file changed, 306 insertions(+) create mode 100644 bittorrent/src/Network/BitTorrent/Tracker/Session.hs (limited to 'bittorrent/src/Network/BitTorrent/Tracker/Session.hs') diff --git a/bittorrent/src/Network/BitTorrent/Tracker/Session.hs b/bittorrent/src/Network/BitTorrent/Tracker/Session.hs new file mode 100644 index 00000000..aa4a832f --- /dev/null +++ b/bittorrent/src/Network/BitTorrent/Tracker/Session.hs @@ -0,0 +1,306 @@ +-- | +-- Copyright : (c) Sam Truzjan 2014 +-- License : BSD +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Multitracker sessions. +-- +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TemplateHaskell #-} +module Network.BitTorrent.Tracker.Session + ( -- * Session + Session + , Event (..) + , newSession + , closeSession + , withSession + + -- * Client send notifications + , notify + , askPeers + + -- * Session state + -- ** Status + , Status (..) + , getStatus + + -- ** Single tracker sessions + , LastScrape (..) + , TrackerSession + , trackerPeers + , trackerScrape + , getSessionState + + -- * Tracker Exchange + -- | BEP28: + , addTracker + , removeTracker + , getTrustedTrackers + ) where + +import Control.Applicative +import Control.Exception +import Control.Concurrent +import Control.Concurrent.Chan.Split as CS +import Control.Monad +import Data.Default +import Data.Fixed +import Data.Foldable as F +import Data.IORef +import Data.List as L +import Data.Maybe +import Data.Time +import Data.Traversable +import Network.URI + +import Data.Torrent +import Network.Address +import Network.BitTorrent.Internal.Cache +import Network.BitTorrent.Internal.Types +import Network.BitTorrent.Tracker.List as TL +import Network.BitTorrent.Tracker.Message +import Network.BitTorrent.Tracker.RPC as RPC + +{----------------------------------------------------------------------- +-- Single tracker session +-----------------------------------------------------------------------} + +-- | Status of this client. +data Status + = Running -- ^ This client is announced and listenning for incoming + -- connections. + | Paused -- ^ This client does not expecting incoming connections. + deriving (Show, Eq, Bounded, Enum) + +-- | Client starting in the paused state. +instance Default Status where + def = Paused + +-- | Tracker session starts with scrape unknown. +instance Default LastScrape where + def = LastScrape Nothing Nothing + +data LastScrape = LastScrape + { -- | Count of leechers the tracker aware of. + scrapeLeechers :: Maybe Int + + -- | Count of seeders the tracker aware of. + , scrapeSeeders :: Maybe Int + } deriving (Show, Eq) + +-- | Single tracker session. +data TrackerSession = TrackerSession + { -- | Used to notify 'Stopped' and 'Completed' events. + statusSent :: !(Maybe Status) + + -- | Can be used to retrieve peer set. + , trackerPeers :: Cached [PeerAddr IP] + + -- | Can be used to show brief swarm stats in client GUI. + , trackerScrape :: Cached LastScrape + } + +-- | Not contacted. +instance Default TrackerSession where + def = TrackerSession Nothing def def + +-- | Do we need to notify this /specific/ tracker? +needNotify :: AnnounceEvent -> Maybe Status -> Maybe Bool +needNotify Started Nothing = Just True +needNotify Stopped Nothing = Just False +needNotify Completed Nothing = Just False +needNotify Started (Just Running) = Nothing +needNotify Stopped (Just Running) = Just True +needNotify Completed (Just Running) = Just True +needNotify Started (Just Paused ) = Just True +needNotify Stopped (Just Paused ) = Just False +needNotify Completed (Just Paused ) = Just True + +-- | Client status after event announce succeed. +nextStatus :: AnnounceEvent -> Maybe Status +nextStatus Started = Just Running +nextStatus Stopped = Just Paused +nextStatus Completed = Nothing -- must keep previous status + +seconds :: Int -> NominalDiffTime +seconds n = realToFrac (toEnum n :: Uni) + +cachePeers :: AnnounceInfo -> IO (Cached [PeerAddr IP]) +cachePeers AnnounceInfo {..} = + newCached (seconds respInterval) + (seconds (fromMaybe respInterval respMinInterval)) + (getPeerList respPeers) + +cacheScrape :: AnnounceInfo -> IO (Cached LastScrape) +cacheScrape AnnounceInfo {..} = + newCached (seconds respInterval) + (seconds (fromMaybe respInterval respMinInterval)) + LastScrape + { scrapeSeeders = respComplete + , scrapeLeechers = respIncomplete + } + +-- | Make announce request to specific tracker returning new state. +notifyTo :: Manager -> Session -> AnnounceEvent + -> TierEntry TrackerSession -> IO TrackerSession +notifyTo mgr s @ Session {..} event (uri, entry @ TrackerSession {..}) = do + let shouldNotify = needNotify event statusSent + mustNotify <- maybe (isExpired trackerPeers) return shouldNotify + if not mustNotify + then return entry + else do + let q = SAnnounceQuery sessionTopic def Nothing (Just event) + res <- RPC.announce mgr uri q + when (statusSent == Nothing) $ do + send sessionEvents (TrackerConfirmed uri) + send sessionEvents (AnnouncedTo uri) + let status' = nextStatus event <|> statusSent + TrackerSession status' <$> cachePeers res <*> cacheScrape res + +{----------------------------------------------------------------------- +-- Multitracker Session +-----------------------------------------------------------------------} + +-- | Multitracker session. +data Session = Session + { -- | Infohash to announce at each 'announce' request. + sessionTopic :: !InfoHash + + -- | Current status of this client is used to filter duplicated + -- notifications, for e.g. we don't want to notify a tracker with + -- ['Stopped', 'Stopped'], the last should be ignored. + , sessionStatus :: !(IORef Status) + + -- | A set of single-tracker sessions. Any request to a tracker + -- must take a lock. + , sessionTrackers :: !(MVar (TrackerList TrackerSession)) + + , sessionEvents :: !(SendPort (Event Session)) + } + +instance EventSource Session where + data Event Session + = TrackerAdded URI + | TrackerConfirmed URI + | TrackerRemoved URI + | AnnouncedTo URI + | SessionClosed + + listen Session {..} = CS.listen sessionEvents + + +-- | Create a new multitracker session in paused state. Tracker list +-- must contant only /trusted/ tracker uris. To start announcing +-- client presence use 'notify'. +newSession :: InfoHash -> TrackerList () -> IO Session +newSession ih origUris = do + urisList <- shuffleTiers origUris + statusRef <- newIORef def + entriesVar <- newMVar (fmap (const def) urisList) + eventStream <- newSendPort + return Session + { sessionTopic = ih + , sessionStatus = statusRef + , sessionTrackers = entriesVar + , sessionEvents = eventStream + } + +-- | Release scarce resources associated with the given session. This +-- function block until all trackers tied with this peer notified with +-- 'Stopped' event. +closeSession :: Manager -> Session -> IO () +closeSession m s @ Session {..} = do + notify m s Stopped + send sessionEvents SessionClosed + +{----------------------------------------------------------------------- +-- Operations +-----------------------------------------------------------------------} + +-- | Normally you need to use 'Control.Monad.Trans.Resource.alloc'. +withSession :: Manager -> InfoHash -> TrackerList () + -> (Session -> IO ()) -> IO () +withSession m ih uris = bracket (newSession ih uris) (closeSession m) + +-- | Get last announced status. The only action can alter this status +-- is 'notify'. +getStatus :: Session -> IO Status +getStatus Session {..} = readIORef sessionStatus + +getSessionState :: Session -> IO [[TierEntry TrackerSession]] +getSessionState Session {..} = TL.toList <$> readMVar sessionTrackers + +-- | Do we need to sent this event to a first working tracker or to +-- the all known good trackers? +allNotify :: AnnounceEvent -> Bool +allNotify Started = False +allNotify Stopped = True +allNotify Completed = True + +notifyAll :: Manager -> Session -> AnnounceEvent -> IO () +notifyAll mgr s @ Session {..} event = do + modifyMVar_ sessionTrackers $ + (traversal (notifyTo mgr s event)) + where + traversal + | allNotify event = traverseAll + | otherwise = traverseTiers + +-- TODO send notifications to tracker periodically. +-- | +-- +-- This function /may/ block until tracker query proceed. +notify :: Manager -> Session -> AnnounceEvent -> IO () +notify mgr ses event = do + prevStatus <- atomicModifyIORef (sessionStatus ses) $ \ s -> + (fromMaybe s (nextStatus event), s) + when (needNotify event (Just prevStatus) == Just True) $ do + notifyAll mgr ses event + +-- TODO run announce if sesion have no peers +-- | The returned list of peers can have duplicates. +-- This function /may/ block. Use async if needed. +askPeers :: Manager -> Session -> IO [PeerAddr IP] +askPeers _mgr ses = do + list <- readMVar (sessionTrackers ses) + L.concat <$> collect (tryTakeData . trackerPeers) list + +collect :: (a -> IO (Maybe b)) -> TrackerList a -> IO [b] +collect f lst = (catMaybes . F.toList) <$> traverse f lst + +--sourcePeers :: Session -> Source (PeerAddr IP) +--sourcePeers + +{----------------------------------------------------------------------- +-- Tracker exchange +-----------------------------------------------------------------------} + +-- Trackers discovered through this protocol SHOULD be treated with a +-- certain amount of suspicion. Since the source of a tracker exchange +-- message cannot be trusted, an implementation SHOULD have a lower +-- number of retries before giving up entirely. + +addTracker :: Session -> URI -> IO () +addTracker Session {..} uri = do + undefined + send sessionEvents (TrackerAdded uri) + +removeTracker :: Manager -> Session -> URI -> IO () +removeTracker m Session {..} uri = do + send sessionEvents (TrackerRemoved uri) + +-- Also, as specified under the definitions section, a tracker that +-- has not worked should never be propagated to other peers over the +-- tracker exchange protocol. + +-- | Return all known trackers. +getTrackers :: Session -> IO [URI] +getTrackers = undefined + +-- | Return trackers from torrent file and +getTrustedTrackers :: Session -> IO [URI] +getTrustedTrackers = undefined -- cgit v1.2.3