Add skeleton of tracker application

1 files changed, 138 insertions, 10 deletions

diff --git a/src/Network/BitTorrent/Tracker/Wai.hs b/src/Network/BitTorrent/Tracker/Wai.hs
index 29e0e952..df56e378 100644
--- a/src/Network/BitTorrent/Tracker/Wai.hs
+++ b/src/Network/BitTorrent/Tracker/Wai.hs
@@ -12,19 +12,30 @@ module Network.BitTorrent.Tracker.Wai
        ( -- * Configuration
          TrackerSettings (..)
 
+         -- * Tracker
+       , Tracker
+       , newTracker
+       , closeTracker
+       , withTracker
+
          -- * Application
        , tracker
        ) where
 
 import Control.Applicative
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad.Trans
 import Control.Monad.Trans.Resource
 import Data.BEncode as BE
-import Data.ByteString
 import Data.Default
+import Data.HashMap.Strict as HM
 import Data.List as L
+import Data.Maybe
 import Network.HTTP.Types
 import Network.Wai
 
+import Data.Torrent.InfoHash
 import Data.Torrent.Progress
 import Network.BitTorrent.Tracker.Message
 
@@ -79,17 +90,134 @@ instance Default TrackerSettings where
     , noPeerId              = False
     }
 
+{-----------------------------------------------------------------------
+--  Swarm
+-----------------------------------------------------------------------}
+
+type PeerSet = [()]
+
+data Swarm = Swarm
+  { leechers   :: !PeerSet
+  , seeders    :: !PeerSet
+  , downloaded :: {-# UNPACK #-} !Int
+  }
 
+instance Default Swarm where
+  def = Swarm
+    { leechers   = []
+    , seeders    = []
+    , downloaded = 0
+    }
+{-
+started :: PeerInfo -> Swarm -> Swarm
+started info Swarm {..} = Swarm
+  { leechers   = insert info leechers
+  , seeders    = delete info seeders
+  , downloaded = downloaded
+  }
+
+regular :: PeerInfo -> Swarm -> Swarm
+regular info Swarm {..} = undefined
+
+stopped :: PeerInfo -> Swarm -> Swarm
+stopped info Swarm {..} = Swarm
+  { leechers   = delete info leechers
+  , seeders    = delete info seeders
+  , downloaded = downloaded
+  }
+
+completed :: PeerInfo -> Swarm -> Swarm
+completed info Swarm {..} = Swarm
+  { leechers   = delete info leechers
+  , seeders    = insert info seeders
+  , downloaded = succ downloaded
+  }
+
+event :: Maybe Event -> Swarm -> Swarm
+event = undefined
+-}
+--peerList :: TrackerSettings -> Swarm -> PeerList IP
+peerList TrackerSettings {..} Swarm {..} = undefined --envelope peers
+  where
+    envelope = if compactPeerList then CompactPeerList else PeerList
+    peers    = []
+
+announceInfo :: TrackerSettings -> Swarm -> AnnounceInfo
+announceInfo settings @ TrackerSettings {..} swarm @ Swarm {..} = AnnounceInfo
+  { respComplete    = Just (L.length seeders)
+  , respIncomplete  = Just (L.length leechers)
+  , respInterval    = reannounceInterval
+  , respMinInterval = reannounceMinInterval
+  , respPeers       = undefined -- peerList settings swarm
+  , respWarning     = Nothing
+  }
+
+scrapeEntry :: Swarm -> ScrapeEntry
+scrapeEntry Swarm {..} = ScrapeEntry
+  { siComplete   = L.length seeders
+  , siDownloaded = downloaded
+  , siIncomplete = L.length leechers
+  , siName       = Nothing
+  }
 
 {-----------------------------------------------------------------------
---  Handlers
+--  Tracker state
 -----------------------------------------------------------------------}
 
-getAnnounceR :: TrackerSettings -> AnnounceRequest -> ResourceT IO AnnounceInfo
-getAnnounceR = undefined
+type Table = HashMap InfoHash Swarm
+
+withSwarm :: TVar Table -> InfoHash -> (Maybe Swarm -> STM (a, Swarm)) -> STM a
+withSwarm tableRef infohash action = do
+  table <- readTVar tableRef
+  (res, swarm') <- action (HM.lookup infohash table)
+  writeTVar tableRef (HM.insert infohash swarm' table)
+  return res
+
+scrapeInfo :: ScrapeQuery -> Table -> [ScrapeEntry]
+scrapeInfo query table = do
+  infohash <- query
+  swarm    <- maybeToList $ HM.lookup infohash table
+  return    $ scrapeEntry swarm
+
+data TrackerState = TrackerState
+  { swarms :: !(TVar Table)
+  }
+
+newState :: IO TrackerState
+newState = TrackerState <$> newTVarIO HM.empty
+
+data Tracker = Tracker
+  { options :: !TrackerSettings
+  , state   :: !TrackerState
+  }
+
+newTracker :: TrackerSettings -> IO Tracker
+newTracker opts = Tracker opts <$> newState
+
+closeTracker :: Tracker -> IO ()
+closeTracker _ = return ()
+
+withTracker :: TrackerSettings -> (Tracker -> IO a) -> IO a
+withTracker opts = bracket (newTracker opts) closeTracker
+
+{-----------------------------------------------------------------------
+--  Handlers
+-----------------------------------------------------------------------}
 
-getScrapeR :: TrackerSettings -> ScrapeQuery -> ResourceT IO ScrapeInfo
-getScrapeR = undefined
+getAnnounceR :: Tracker -> AnnounceRequest -> ResourceT IO AnnounceInfo
+getAnnounceR Tracker {..} AnnounceRequest {..} = do
+  return undefined
+{-
+  atomically $ do
+    withSwarm (swarms state) (reqInfoHash announceQuery) $ \ mswarm ->
+      case mswarm of
+        Nothing -> return undefined
+        Just s  -> return undefined
+-}
+getScrapeR :: Tracker -> ScrapeQuery -> ResourceT IO ScrapeInfo
+getScrapeR Tracker {..} query = do
+  table <- liftIO $ readTVarIO (swarms state)
+  return $ undefined $ scrapeInfo query table
 
 {-----------------------------------------------------------------------
 --  Routing
@@ -106,19 +234,19 @@ scrapeResponse info = responseLBS ok200 headers $ BE.encode info
     headers = [(hContentType, scrapeType)]
 
 -- content-type: "text/plain"!
-tracker :: TrackerSettings -> Application
-tracker settings @ TrackerSettings {..} Request {..}
+tracker :: Tracker -> Application
+tracker t @ (Tracker TrackerSettings {..} _) Request {..}
   | requestMethod /= methodGet
   = return $ responseLBS methodNotAllowed405 [] ""
 
   | rawPathInfo == announcePath = do
     case parseAnnounceRequest $ queryToSimpleQuery queryString of
-      Right query -> announceResponse <$> getAnnounceR settings query
+      Right query -> announceResponse <$> getAnnounceR t query
       Left  msg   -> return $ responseLBS (parseFailureStatus msg) [] ""
 
   | rawPathInfo == scrapePath   = do
     case Right $ parseScrapeQuery $ queryToSimpleQuery queryString of -- TODO
-      Right query -> scrapeResponse <$> getScrapeR settings query
+      Right query -> scrapeResponse <$> getScrapeR t query
       Left  msg   -> return $ responseLBS badRequest400 [] ""
 
   |     otherwise               = undefined --badPath