[Internal] Add EventSource class

10 files changed, 74 insertions, 104 deletions

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;
@@ -205,21 +215,6 @@ 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'.
@@ -221,20 +230,6 @@ closeSession m s @ Session {..} = do
   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)