src/FuncTorrent/Tracker.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module FuncTorrent.Tracker
   3        (runTracker
   4        , getConnectedPeers
   5        , newTracker
   6        ) where
   7
   8 import Control.Concurrent(forkIO)
   9 import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
  10 import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar)
  11 import Control.Monad.State (StateT, liftIO, get, runStateT)
  12 import Control.Monad (forever)
  13 import Data.ByteString.Char8 (ByteString)
  14 import Data.List (isPrefixOf)
  15 import Network (PortNumber)
  16
  17 import FuncTorrent.Tracker.Http (trackerLoop)
  18 import FuncTorrent.Tracker.Types (TState(..), TrackerEventState(..), TrackerProtocol(..), TrackerMsg(..))
  19 import qualified FuncTorrent.FileSystem as FS (MsgChannel)
  20 import FuncTorrent.Peer (Peer)
  21
  22 type MsgChannel = Chan TrackerMsg
  23
  24 newTracker :: IO MsgChannel
  25 newTracker = newChan
  26
  27 runTracker :: MsgChannel -> FS.MsgChannel -> ByteString -> PortNumber
  28            -> String -> [String] -> Integer -> IO ()
  29 runTracker msgChannel fsChan infohash port peerId announceList sz = do
  30   ps <- newEmptyMVar
  31   let initialTState = TState { currentState = None
  32                              , connectedPeers = ps
  33                              , left = sz }
  34       turl = head announceList
  35   case (getTrackerType turl) of
  36     Http -> do
  37       _ <- forkIO $ trackerLoop turl port peerId infohash fsChan initialTState
  38       runStateT (msgHandler msgChannel) initialTState
  39       return ()
  40     _ -> do
  41       error "Tracker Protocol unimplemented"
  42
  43 getTrackerType :: String -> TrackerProtocol
  44 getTrackerType url | isPrefixOf "http://" url = Http
  45                    | isPrefixOf "udp://" url  = Udp
  46                    | otherwise                = UnknownProtocol
  47
  48
  49 msgHandler :: MsgChannel -> StateT TState IO ()
  50 msgHandler c = forever $ do
  51   st <- get
  52   peers <- liftIO $ readMVar (connectedPeers st)
  53   msg <- liftIO recvMsg
  54   liftIO $ sendResponse msg peers
  55     where
  56       recvMsg = readChan c
  57       sendResponse msg peers =
  58         case msg of
  59           GetConnectedPeersMsg var -> do
  60             putMVar var peers
  61           _ -> do
  62             putStrLn "Unhandled Tracker Msg"
  63
  64 getConnectedPeers :: MsgChannel -> IO [Peer]
  65 getConnectedPeers c = do
  66   v <- newEmptyMVar
  67   writeChan c (GetConnectedPeersMsg v)
  68   ps <- readMVar v
  69   return ps