From 1beb66f98504a39c8a6c976f243a1f69ffb48d8d Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Fri, 4 Apr 2014 04:51:36 +0400 Subject: [Internal] Add EventSource class --- bittorrent.cabal | 1 + src/Network/BitTorrent.hs | 16 +++++----- src/Network/BitTorrent/Client.hs | 9 ------ src/Network/BitTorrent/Client/Handle.hs | 7 ----- src/Network/BitTorrent/Client/Types.hs | 27 ++++++++-------- src/Network/BitTorrent/Exchange.hs | 5 --- src/Network/BitTorrent/Exchange/Session.hs | 46 +++++++++------------------- src/Network/BitTorrent/Internal/Types.hs | 10 ++++++ src/Network/BitTorrent/Tracker.hs | 3 +- src/Network/BitTorrent/Tracker/Message.hs | 20 ++++++------ src/Network/BitTorrent/Tracker/RPC.hs | 2 +- src/Network/BitTorrent/Tracker/Session.hs | 49 ++++++++++++++---------------- 12 files changed, 83 insertions(+), 112 deletions(-) create mode 100644 src/Network/BitTorrent/Internal/Types.hs diff --git a/bittorrent.cabal b/bittorrent.cabal index 7058d704..5c53d3fc 100644 --- a/bittorrent.cabal +++ b/bittorrent.cabal @@ -80,6 +80,7 @@ library Network.BitTorrent.Exchange.Session.Metadata Network.BitTorrent.Exchange.Session.Status Network.BitTorrent.Internal.Cache + Network.BitTorrent.Internal.Types Network.BitTorrent.Tracker Network.BitTorrent.Tracker.List Network.BitTorrent.Tracker.Message diff --git a/src/Network/BitTorrent.hs b/src/Network/BitTorrent.hs index 8cb928d3..bcc7cfcf 100644 --- a/src/Network/BitTorrent.hs +++ b/src/Network/BitTorrent.hs @@ -29,10 +29,6 @@ module Network.BitTorrent , getClient , simpleClient - -- ** Events - , ClientEvent (..) - , subscription - -- * Torrent -- ** Source , InfoHash @@ -55,9 +51,13 @@ module Network.BitTorrent , start , pause , stop + + -- * Events + , EventSource (..) ) where -import Data.Torrent as BT -import Data.Torrent.InfoHash as BT -import Data.Torrent.Magnet as BT -import Network.BitTorrent.Client as BT \ No newline at end of file +import Data.Torrent +import Data.Torrent.InfoHash +import Data.Torrent.Magnet +import Network.BitTorrent.Client +import Network.BitTorrent.Internal.Types \ No newline at end of file diff --git a/src/Network/BitTorrent/Client.hs b/src/Network/BitTorrent/Client.hs index 93c5f47e..bf6740c3 100644 --- a/src/Network/BitTorrent/Client.hs +++ b/src/Network/BitTorrent/Client.hs @@ -21,10 +21,6 @@ module Network.BitTorrent.Client , withClient , simpleClient - -- ** Events - , ClientEvent (..) - , Network.BitTorrent.Client.subscription - -- * BitTorrent monad , MonadBitTorrent (..) , BitTorrent @@ -166,11 +162,6 @@ simpleClient m = do runStderrLoggingT $ LoggingT $ \ logger -> do withClient def logger (`runBitTorrent` m) -subscription :: BitTorrent (ReceivePort ClientEvent) -subscription = do - Client {..} <- getClient - liftIO $ listen clientEvents - {----------------------------------------------------------------------- -- Torrent identifiers -----------------------------------------------------------------------} diff --git a/src/Network/BitTorrent/Client/Handle.hs b/src/Network/BitTorrent/Client/Handle.hs index 25316a0a..0d1b7f92 100644 --- a/src/Network/BitTorrent/Client/Handle.hs +++ b/src/Network/BitTorrent/Client/Handle.hs @@ -14,11 +14,7 @@ module Network.BitTorrent.Client.Handle -- * Query , getHandle - , HandleStatus (..) , getStatus - - -- * Events - , HandleEvent (..) ) where import Control.Concurrent.Chan.Split @@ -192,6 +188,3 @@ getHandle ih = do getStatus :: Handle -> IO HandleStatus getStatus Handle {..} = readMVar handleStatus - -subscription :: Handle -> IO (ReceivePort HandleEvent) -subscription Handle {..} = listen handleEvents diff --git a/src/Network/BitTorrent/Client/Types.hs b/src/Network/BitTorrent/Client/Types.hs index aa876ff1..c019bc5f 100644 --- a/src/Network/BitTorrent/Client/Types.hs +++ b/src/Network/BitTorrent/Client/Types.hs @@ -17,13 +17,12 @@ module Network.BitTorrent.Client.Types , MonadBitTorrent (..) -- * Events - , ClientEvent (..) - , HandleEvent (..) + , Types.Event (..) ) where import Control.Applicative import Control.Concurrent -import Control.Concurrent.Chan.Split +import Control.Concurrent.Chan.Split as CS import Control.Monad.Base import Control.Monad.Logger import Control.Monad.Reader @@ -36,19 +35,17 @@ import Network import System.Log.FastLogger import Data.Torrent.InfoHash +import Network.BitTorrent.Internal.Types as Types import Network.BitTorrent.Core import Network.BitTorrent.DHT as DHT import Network.BitTorrent.Exchange as Exchange -import Network.BitTorrent.Tracker as Tracker +import Network.BitTorrent.Tracker as Tracker hiding (Event) data HandleStatus = Running | Stopped deriving (Show, Eq) -data HandleEvent - = StatusChanged HandleStatus - data Handle = Handle { handleTopic :: !InfoHash , handlePrivate :: !Bool @@ -56,9 +53,13 @@ data Handle = Handle , handleStatus :: !(MVar HandleStatus) , handleTrackers :: !Tracker.Session , handleExchange :: !Exchange.Session - , handleEvents :: !(SendPort HandleEvent) + , handleEvents :: !(SendPort (Event Handle)) } +instance EventSource Handle where + data Event Handle = StatusChanged HandleStatus + listen Handle {..} = CS.listen undefined + data Client = Client { clientPeerId :: !PeerId , clientListenerPort :: !PortNumber @@ -69,7 +70,7 @@ data Client = Client , clientNode :: !(Node IPv4) , clientTorrents :: !(MVar (HashMap InfoHash Handle)) , clientLogger :: !LogFun - , clientEvents :: !(SendPort ClientEvent) + , clientEvents :: !(SendPort (Event Client)) } instance Eq Client where @@ -78,6 +79,10 @@ instance Eq Client where instance Ord Client where compare = comparing clientPeerId +instance EventSource Client where + data Event Client = TorrentAdded InfoHash + listen Client {..} = CS.listen clientEvents + -- | External IP address of a host running a bittorrent client -- software may be used to acknowledge remote peer the host connected -- to. See 'Network.BitTorrent.Exchange.Message.ExtendedHandshake'. @@ -88,10 +93,6 @@ externalAddr Client {..} = PeerAddr , peerPort = clientListenerPort } -data ClientEvent - = TorrentAdded InfoHash - deriving (Show, Eq) - {----------------------------------------------------------------------- -- BitTorrent monad -----------------------------------------------------------------------} diff --git a/src/Network/BitTorrent/Exchange.hs b/src/Network/BitTorrent/Exchange.hs index a90c19f8..ce71e286 100644 --- a/src/Network/BitTorrent/Exchange.hs +++ b/src/Network/BitTorrent/Exchange.hs @@ -27,13 +27,8 @@ module Network.BitTorrent.Exchange -- * Connections , connect - - -- * Events - , SessionEvent (..) - , subscription ) where -import Network.BitTorrent.Exchange.Connection hiding (Options) import Network.BitTorrent.Exchange.Manager import Network.BitTorrent.Exchange.Message import Network.BitTorrent.Exchange.Session diff --git a/src/Network/BitTorrent/Exchange/Session.hs b/src/Network/BitTorrent/Exchange/Session.hs index b6d7f810..91ea8da9 100644 --- a/src/Network/BitTorrent/Exchange/Session.hs +++ b/src/Network/BitTorrent/Exchange/Session.hs @@ -1,9 +1,11 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveDataTypeable #-} module Network.BitTorrent.Exchange.Session ( -- * Session Session + , Event (..) , LogFun , sessionLogger @@ -19,10 +21,6 @@ module Network.BitTorrent.Exchange.Session -- * Query , waitMetadata , takeMetadata - - -- * Events - , SessionEvent (..) - , subscription ) where import Control.Applicative @@ -52,6 +50,7 @@ import Data.Torrent.Bitfield as BF import Data.Torrent.InfoHash import Data.Torrent.Piece import qualified Data.Torrent.Piece as Torrent (Piece ()) +import Network.BitTorrent.Internal.Types import Network.BitTorrent.Core import Network.BitTorrent.Exchange.Block as Block import Network.BitTorrent.Exchange.Connection @@ -138,7 +137,7 @@ data Session = Session { sessionPeerId :: !(PeerId) , sessionTopic :: !(InfoHash) , sessionLogger :: !(LogFun) - , sessionEvents :: !(SendPort SessionEvent) + , sessionEvents :: !(SendPort (Event Session)) , sessionState :: !(MVar SessionState) @@ -162,6 +161,17 @@ data Session = Session , connectionsBroadcast :: !(Chan Message) } +instance EventSource Session where + data Event Session + = ConnectingTo (PeerAddr IP) + | ConnectionEstablished (PeerAddr IP) + | ConnectionAborted + | ConnectionClosed (PeerAddr IP) + | SessionClosed + deriving Show + + listen Session {..} = CS.listen sessionEvents + newSession :: LogFun -> PeerAddr (Maybe IP) -- ^ /external/ address of this peer; -> FilePath -- ^ root directory for content files; @@ -204,21 +214,6 @@ closeSession Session {..} = do withSession :: () withSession = error "withSession" -{----------------------------------------------------------------------- --- Session events ------------------------------------------------------------------------} - -data SessionEvent - = ConnectingTo (PeerAddr IP) - | ConnectionEstablished (PeerAddr IP) - | ConnectionAborted - | ConnectionClosed (PeerAddr IP) - | SessionClosed - deriving Show - -subscription :: Session -> IO (ReceivePort SessionEvent) -subscription Session {..} = listen sessionEvents - {----------------------------------------------------------------------- -- Logging -----------------------------------------------------------------------} @@ -577,14 +572,3 @@ mainWire = do logEvent "Connection established" iterM logMessage =$= exchange =$= iterM logMessage lift finishedConnection - -data Event = NewMessage (PeerAddr IP) Message - | Timeout -- for scheduling - -type Exchange a = Wire Session a - -awaitEvent :: Exchange Event -awaitEvent = error "awaitEvent" - -yieldEvent :: Exchange Event -yieldEvent = error "yieldEvent" diff --git a/src/Network/BitTorrent/Internal/Types.hs b/src/Network/BitTorrent/Internal/Types.hs new file mode 100644 index 00000000..d157db3e --- /dev/null +++ b/src/Network/BitTorrent/Internal/Types.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeFamilies #-} +module Network.BitTorrent.Internal.Types + ( EventSource (..) + ) where + +import Control.Concurrent.Chan.Split + +class EventSource source where + data Event source + listen :: source -> IO (ReceivePort (Event source)) diff --git a/src/Network/BitTorrent/Tracker.hs b/src/Network/BitTorrent/Tracker.hs index 46589eb7..6db67559 100644 --- a/src/Network/BitTorrent/Tracker.hs +++ b/src/Network/BitTorrent/Tracker.hs @@ -22,12 +22,13 @@ module Network.BitTorrent.Tracker -- * Multitracker session , trackerList , Session + , Event (..) , newSession , closeSession , withSession -- ** Events - , Event (..) + , AnnounceEvent (..) , notify , askPeers diff --git a/src/Network/BitTorrent/Tracker/Message.hs b/src/Network/BitTorrent/Tracker/Message.hs index 8131ecf0..ffe36c82 100644 --- a/src/Network/BitTorrent/Tracker/Message.hs +++ b/src/Network/BitTorrent/Tracker/Message.hs @@ -30,8 +30,8 @@ module Network.BitTorrent.Tracker.Message ( -- * Announce -- ** Query - Event(..) - , AnnounceQuery(..) + AnnounceEvent (..) + , AnnounceQuery (..) , renderAnnounceQuery , ParamParseFailure , parseAnnounceQuery @@ -136,7 +136,7 @@ import Network.BitTorrent.Core -----------------------------------------------------------------------} -- | Events are used to specify which kind of announce query is performed. -data Event +data AnnounceEvent -- | For the first request: when download first begins. = Started @@ -150,10 +150,10 @@ data Event | Completed deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable) -$(deriveJSON omitRecordPrefix ''Event) +$(deriveJSON omitRecordPrefix ''AnnounceEvent) -- | HTTP tracker protocol compatible encoding. -instance QueryValueLike Event where +instance QueryValueLike AnnounceEvent where toQueryValue e = toQueryValue (Char.toLower x : xs) where (x : xs) = show e -- INVARIANT: this is always nonempty list @@ -161,17 +161,17 @@ instance QueryValueLike Event where type EventId = Word32 -- | UDP tracker encoding event codes. -eventId :: Event -> EventId +eventId :: AnnounceEvent -> EventId eventId Completed = 1 eventId Started = 2 eventId Stopped = 3 -- TODO add Regular event -putEvent :: Putter (Maybe Event) +putEvent :: Putter (Maybe AnnounceEvent) putEvent Nothing = putWord32be 0 putEvent (Just e) = putWord32be (eventId e) -getEvent :: S.Get (Maybe Event) +getEvent :: S.Get (Maybe AnnounceEvent) getEvent = do eid <- getWord32be case eid of @@ -221,7 +221,7 @@ data AnnounceQuery = AnnounceQuery -- | If not specified, the request is regular periodic -- request. Regular request should be sent - , reqEvent :: Maybe Event + , reqEvent :: Maybe AnnounceEvent } deriving (Show, Eq, Typeable) $(deriveJSON omitRecordPrefix ''AnnounceQuery) @@ -351,7 +351,7 @@ instance FromParam Int where instance FromParam PortNumber where fromParam bs = fromIntegral <$> (fromParam bs :: Maybe Word32) -instance FromParam Event where +instance FromParam AnnounceEvent where fromParam bs = do (x, xs) <- BC.uncons bs readMaybe $ BC.unpack $ BC.cons (Char.toUpper x) xs diff --git a/src/Network/BitTorrent/Tracker/RPC.hs b/src/Network/BitTorrent/Tracker/RPC.hs index 39d1b09f..dc1bd4ec 100644 --- a/src/Network/BitTorrent/Tracker/RPC.hs +++ b/src/Network/BitTorrent/Tracker/RPC.hs @@ -63,7 +63,7 @@ data SAnnounceQuery = SAnnounceQuery { sInfoHash :: InfoHash , sProgress :: Progress , sNumWant :: Maybe Int - , sEvent :: Maybe Event + , sEvent :: Maybe AnnounceEvent } fillAnnounceQuery :: PeerInfo -> SAnnounceQuery -> AnnounceQuery diff --git a/src/Network/BitTorrent/Tracker/Session.hs b/src/Network/BitTorrent/Tracker/Session.hs index e82501dd..5aa9c0eb 100644 --- a/src/Network/BitTorrent/Tracker/Session.hs +++ b/src/Network/BitTorrent/Tracker/Session.hs @@ -8,17 +8,18 @@ -- Multitracker sessions. -- {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TemplateHaskell #-} module Network.BitTorrent.Tracker.Session ( -- * Session Session + , Event (..) , newSession , closeSession , withSession -- * Client send notifications - , Event (..) , notify , askPeers @@ -39,16 +40,12 @@ module Network.BitTorrent.Tracker.Session , addTracker , removeTracker , getTrustedTrackers - - -- * Events - , SessionEvent (..) - , subscribe ) where import Control.Applicative import Control.Exception import Control.Concurrent -import Control.Concurrent.Chan.Split +import Control.Concurrent.Chan.Split as CS import Control.Monad import Data.Aeson import Data.Aeson.TH @@ -66,6 +63,7 @@ import Data.Torrent.InfoHash import Data.Torrent.JSON import Network.BitTorrent.Core 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 @@ -123,7 +121,7 @@ instance Default TrackerSession where def = TrackerSession Nothing def def -- | Do we need to notify this /specific/ tracker? -needNotify :: Event -> Maybe Status -> Maybe Bool +needNotify :: AnnounceEvent -> Maybe Status -> Maybe Bool needNotify Started Nothing = Just True needNotify Stopped Nothing = Just False needNotify Completed Nothing = Just False @@ -135,7 +133,7 @@ needNotify Stopped (Just Paused ) = Just False needNotify Completed (Just Paused ) = Just True -- | Client status after event announce succeed. -nextStatus :: Event -> Maybe Status +nextStatus :: AnnounceEvent -> Maybe Status nextStatus Started = Just Running nextStatus Stopped = Just Paused nextStatus Completed = Nothing -- must keep previous status @@ -159,7 +157,7 @@ cacheScrape AnnounceInfo {..} = } -- | Make announce request to specific tracker returning new state. -notifyTo :: Manager -> Session -> Event +notifyTo :: Manager -> Session -> AnnounceEvent -> TierEntry TrackerSession -> IO TrackerSession notifyTo mgr s @ Session {..} event (uri, entry @ TrackerSession {..}) = do let shouldNotify = needNotify event statusSent @@ -193,9 +191,20 @@ data Session = Session -- must take a lock. , sessionTrackers :: !(MVar (TrackerList TrackerSession)) - , sessionEvents :: !(SendPort SessionEvent) + , 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'. @@ -220,20 +229,6 @@ closeSession m s @ Session {..} = do notify m s Stopped send sessionEvents SessionClosed -{----------------------------------------------------------------------- --- Events ------------------------------------------------------------------------} - -data SessionEvent - = TrackerAdded URI - | TrackerConfirmed URI - | TrackerRemoved URI - | AnnouncedTo URI - | SessionClosed - -subscribe :: Session -> IO (ReceivePort SessionEvent) -subscribe Session {..} = listen sessionEvents - {----------------------------------------------------------------------- -- Operations -----------------------------------------------------------------------} @@ -253,12 +248,12 @@ 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 :: Event -> Bool +allNotify :: AnnounceEvent -> Bool allNotify Started = False allNotify Stopped = True allNotify Completed = True -notifyAll :: Manager -> Session -> Event -> IO () +notifyAll :: Manager -> Session -> AnnounceEvent -> IO () notifyAll mgr s @ Session {..} event = do modifyMVar_ sessionTrackers $ (traversal (notifyTo mgr s event)) @@ -271,7 +266,7 @@ notifyAll mgr s @ Session {..} event = do -- | -- -- This function /may/ block until tracker query proceed. -notify :: Manager -> Session -> Event -> IO () +notify :: Manager -> Session -> AnnounceEvent -> IO () notify mgr ses event = do prevStatus <- atomicModifyIORef (sessionStatus ses) $ \ s -> (fromMaybe s (nextStatus event), s) -- cgit v1.2.3