1 {-# LANGUAGE OverloadedStrings #-}
2 module FuncTorrent.Tracker
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)
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)
22 type MsgChannel = Chan TrackerMsg
24 newTracker :: IO MsgChannel
27 runTracker :: MsgChannel -> FS.MsgChannel -> ByteString -> PortNumber
28 -> String -> [String] -> Integer -> IO ()
29 runTracker msgChannel fsChan infohash port peerId announceList sz = do
31 let initialTState = TState { currentState = None
34 turl = head announceList
35 case (getTrackerType turl) of
37 _ <- forkIO $ trackerLoop turl port peerId infohash fsChan initialTState
38 runStateT (msgHandler msgChannel) initialTState
41 error "Tracker Protocol unimplemented"
43 getTrackerType :: String -> TrackerProtocol
44 getTrackerType url | isPrefixOf "http://" url = Http
45 | isPrefixOf "udp://" url = Udp
46 | otherwise = UnknownProtocol
49 msgHandler :: MsgChannel -> StateT TState IO ()
50 msgHandler c = forever $ do
52 peers <- liftIO $ readMVar (connectedPeers st)
54 liftIO $ sendResponse msg peers
57 sendResponse msg peers =
59 GetConnectedPeersMsg var -> do
62 putStrLn "Unhandled Tracker Msg"
64 getConnectedPeers :: MsgChannel -> IO [Peer]
65 getConnectedPeers c = do
67 writeChan c (GetConnectedPeersMsg v)