3 files changed, 33 insertions, 38 deletions

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)